/-
Copyright (c) 2021 David Wärn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Wärn, Scott Morrison
-/
import data.opposite

/-!
# Quivers

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

This module defines quivers. A quiver on a type `V` of vertices assigns to every
pair `a b : V` of vertices a type `a ⟶ b` of arrows from `a` to `b`. This
is a very permissive notion of directed graph.

## Implementation notes

Currently `quiver` is defined with `arrow : V → V → Sort v`.
This is different from the category theory setup,
where we insist that morphisms live in some `Type`.
There's some balance here: it's nice to allow `Prop` to ensure there are no multiple arrows,
but it is also results in error-prone universe signatures when constraints require a `Type`.
-/

open opposite

-- We use the same universe order as in category theory.
-- See note [category_theory universes]
universes v v₁ v₂ u u₁ u₂

/--
A quiver `G` on a type `V` of vertices assigns to every pair `a b : V` of vertices
a type `a ⟶ b` of arrows from `a` to `b`.

For graphs with no repeated edges, one can use `quiver.{0} V`, which ensures
`a ⟶ b : Prop`. For multigraphs, one can use `quiver.{v+1} V`, which ensures
`a ⟶ b : Type v`.

Because `category` will later extend this class, we call the field `hom`.
Except when constructing instances, you should rarely see this, and use the `⟶` notation instead.
-/
class quiver (V : Type u) :=
(hom : V → V → Sort v)

infixr ` ⟶ `:10 := quiver.hom -- type as \h

/--
A morphism of quivers. As we will later have categorical functors extend this structure,
we call it a `prefunctor`.
-/
structure prefunctor (V : Type u₁) [quiver.{v₁} V] (W : Type u₂) [quiver.{v₂} W] :=
(obj [] : V → W)
(map : Π {X Y : V}, (X ⟶ Y) → (obj X ⟶ obj Y))

namespace prefunctor

@[ext]
lemma ext {V : Type u} [quiver.{v₁} V] {W : Type u₂} [quiver.{v₂} W]
  {F G : prefunctor V W}
  (h_obj : ∀ X, F.obj X = G.obj X)
  (h_map : ∀ (X Y : V) (f : X ⟶ Y),
           F.map f = eq.rec_on (h_obj Y).symm (eq.rec_on (h_obj X).symm (G.map f))) : F = G :=
begin
  cases F with F_obj _, cases G with G_obj _,
  obtain rfl : F_obj = G_obj, by { ext X, apply h_obj },
  congr,
  funext X Y f,
  simpa using h_map X Y f,
end

/--
The identity morphism between quivers.
-/
@[simps]
def id (V : Type*) [quiver V] : prefunctor V V :=
{ obj := id,
  map := λ X Y f, f, }

instance (V : Type*) [quiver V] : inhabited (prefunctor V V) := ⟨id V⟩

/--
Composition of morphisms between quivers.
-/
@[simps]
def comp {U : Type*} [quiver U] {V : Type*} [quiver V] {W : Type*} [quiver W]
  (F : prefunctor U V) (G : prefunctor V W) : prefunctor U W :=
{ obj := λ X, G.obj (F.obj X),
  map := λ X Y f, G.map (F.map f), }

@[simp] lemma comp_id {U : Type*} [quiver U] {V : Type*} [quiver V] (F : prefunctor U V) :
  F.comp (id _) = F := by { cases F, refl, }

@[simp] lemma id_comp {U : Type*} [quiver U] {V : Type*} [quiver V] (F : prefunctor U V) :
  (id _).comp F = F := by { cases F, refl, }

@[simp]
lemma comp_assoc
  {U V W Z : Type*} [quiver U] [quiver V] [quiver W] [quiver Z]
  (F : prefunctor U V) (G : prefunctor V W) (H : prefunctor W Z) :
  (F.comp G).comp H = F.comp (G.comp H) := rfl

infix ` ⥤q `:50 := prefunctor

infix ` ⋙q `:60 := prefunctor.comp

notation `𝟭q` := id

end prefunctor

namespace quiver

/-- `Vᵒᵖ` reverses the direction of all arrows of `V`. -/
instance opposite {V} [quiver V] : quiver Vᵒᵖ :=
⟨λ a b, (unop b) ⟶ (unop a)⟩

/--
The opposite of an arrow in `V`.
-/
def hom.op {V} [quiver V] {X Y : V} (f : X ⟶ Y) : op Y ⟶ op X := f
/--
Given an arrow in `Vᵒᵖ`, we can take the "unopposite" back in `V`.
-/
def hom.unop {V} [quiver V] {X Y : Vᵒᵖ} (f : X ⟶ Y) : unop Y ⟶ unop X := f

attribute [irreducible] quiver.opposite

/-- A type synonym for a quiver with no arrows. -/
@[nolint has_nonempty_instance]
def empty (V) : Type u := V

instance empty_quiver (V : Type u) : quiver.{u} (empty V) := ⟨λ a b, pempty⟩

@[simp] lemma empty_arrow {V : Type u} (a b : empty V) : (a ⟶ b) = pempty := rfl

/-- A quiver is thin if it has no parallel arrows. -/
@[reducible] def is_thin (V : Type u) [quiver V] := ∀ (a b : V), subsingleton (a ⟶ b)

end quiver


import data.equiv
/- this file contains the lines

instance : has_coe_to_fun (α ≃ β) :=
⟨_, to_fun⟩

-/

-- this fails:
--theorem XXX {α β : Type} : has_coe_to_fun (equiv α β) := by apply_instance

variables {α β : Type} (e : equiv α β) (a : α)

#check (⇑e : α → β)
#print has_coe_to_fun
#print notation ⇑
#print coe_fn
#check e
-- #check (a : e)


import verification.semantics.stream_props
import verification.semantics.stream_zero
import verification.misc
import verification.semantics.finsuppeval
import tactic.zify
import tactic.linarith
import tactic.abel

open_locale classical
noncomputable theory

variables {ι : Type} {α : Type*}
  [linear_order ι]

section defs
variables [has_zero α]
  [has_add α]

@[simps]
instance : has_add (Stream ι α) := ⟨λ a b,
{ σ := a.σ × b.σ,
  valid := λ s, a.valid s.1 ∨ b.valid s.2,
  ready := λ s, (a.to_order s.1 ≤ b.to_order s.2 ∧ a.ready s.1) ∨ (b.to_order s.2 ≤ a.to_order s.1 ∧ b.ready s.2),
  next := λ s h, (if H : a.to_order s.1 ≤ b.to_order s.2 then a.next s.1 (valid_of_le_or h H) else s.1,
                  if H : b.to_order s.2 ≤ a.to_order s.1 then b.next s.2 (valid_of_le_or h.symm H) else s.2),
  index := λ s h, option.get (show (min (a.index' s.1) (b.index' s.2)).is_some, by simpa),
  value := λ s h, (if a.to_order s.1 ≤ b.to_order s.2 then a.value' s.1 else 0) +
                  (if b.to_order s.2 ≤ a.to_order s.1 then b.value' s.2 else 0) }⟩

-- Some weird inequality lemma I extracted from the main proof
private lemma succ_le_min_succ_add_succ {a b b' d : ℕ} (ha : a ≤ b + d) (hb' : b ≤ b') :
  a + 1 ≤ (min b' (b + 1)) + (d + 1) :=
by { rw [← add_assoc, nat.succ_le_succ_iff, min_def], split_ifs; linarith, }

end defs

section lemmas
variables {a : Stream ι α} {b : Stream ι α} {x : a.σ} {y : b.σ}

section index_lemmas
variables [has_zero α] [has_add α]

lemma lt_index_of_valid (h : a.to_order x ≤ b.to_order y) (hva : a.valid x) :
  ↑(a.index x hva) ≤ b.index' y :=
by { simp only [← Stream.index'_val hva], exact prod.lex.fst_le_of_le h, }

lemma Stream.min_index (h : a.to_order x ≤ b.to_order y) (hva : a.valid x) :
  min (a.index' x) (b.index' y) = a.index x hva :=
by { rw [Stream.index'_val hva, min_eq_left_iff], exact lt_index_of_valid h hva, }

@[simp] lemma Stream.add_index' (a : Stream ι α) (b : Stream ι α) (xy : a.σ × b.σ) :
  (a + b).index' xy = min (a.index' xy.1) (b.index' xy.2) :=
begin
  rcases xy with ⟨x, y⟩,
  by_cases H : (a + b).valid (x, y),
  { simp [Stream.index'_val H], },
  { have : ¬a.valid x ∧ ¬b.valid y := by { simpa [not_or_distrib] using H, },
    simp [Stream.index', H, this], }
end

end index_lemmas

section value_lemmas
variables [add_comm_monoid α]

lemma Stream.add.eval₀_left (h : a.to_order x < b.to_order y) (hva H) :
  (a + b).eval₀ (x, y) H = a.eval₀ x hva :=
begin
  simp [Stream.eval₀, h.le, h.not_le],
  split_ifs with H,
  { simp [Stream.min_index h.le hva, Stream.value'_val H], },
  { refl, },
end

lemma Stream.add_eval₀_right (h : b.to_order y < a.to_order x) (hvb H) :
  (a + b).eval₀ (x, y) H = b.eval₀ y hvb :=
begin
  simp [Stream.eval₀, h.le, h.not_le],
  split_ifs with H,
  { simp [H, Stream.min_index h.le hvb, Stream.value'_val H, min_comm (a.index' _) _], },
  { refl, },
end

lemma Stream.add_eval₀_both (h : a.to_order x = b.to_order y) (hva hvb H) :
  (a + b).eval₀ (x, y) H = a.eval₀ x hva + b.eval₀ y hvb :=
begin
  simp [Stream.eval₀, h],
  have : a.index _ hva = b.index _ hvb, { simpa [Stream.index'_val hva, Stream.index'_val hvb] using congr_arg prod.fst h, },
  by_cases H₁ : a.ready x; by_cases H₂ : b.ready y; simp [H₁, H₂, Stream.value', Stream.min_index h.le hva, this],
end

end value_lemmas
end lemmas

@[elab_as_eliminator]
theorem Stream.add_induction [has_zero α] [has_add α] (a : Stream ι α) (b : Stream ι α) (x : a.σ) (y : b.σ)
  {B₁ B₂ : ℕ} (ha : a.bound_valid B₁ x) (hb : b.bound_valid B₂ y)
  (P : ∀ (x : a.σ) (y : b.σ) (k₁ : ℕ) (k₂ : ℕ) (N : ℕ), Prop)
  (hP_base : ∀ (x y), P x y 0 0 0)
  (hP_invalid : ∀ (x y B₁ B₂ N) (H : ¬(a + b).valid (x, y)) (hvx : ¬a.valid x) (hvy : ¬b.valid y), a.bound_valid B₁ x → b.bound_valid B₂ y → P x y B₁ B₂ N)
  (hP_advance_a : ∀ (x y k₁ k₂ N) (hvx : a.valid x), (a + b).valid (x, y) → a.to_order x < b.to_order y → P (a.next x hvx) y k₁ k₂ N → P x y (k₁ + 1) k₂ (N + 1))
  (hP_advance_b : ∀ (x y k₁ k₂ N) (hvy : b.valid y), (a + b).valid (x, y) → b.to_order y < a.to_order x → P x (b.next y hvy) k₁ k₂ N → P x y k₁ (k₂ + 1) (N + 1))
  (hP_advance_both : ∀ (x y k₁ k₂ B₁ N) (hvx : a.valid x) (hvy : b.valid y), (a + b).valid (x, y) → a.bound_valid (B₁ + 1) x → a.to_order x = b.to_order y → P (a.next x hvx) (b.next y hvy) k₁ k₂ N → P x y (min (B₁ + 1) (k₁ + 1)) (k₂ + 1) (N + 1)) :
  P x y B₁ B₂ (B₁ + B₂) :=
begin
  suffices : ∀ n ≤ B₁ + B₂, ∃ (k₁ k₂ : ℕ), k₁ ≤ B₁ ∧ k₂ ≤ B₂ ∧ n ≤ k₁ + k₂ ∧ P x y k₁ k₂ n,
  { obtain ⟨k₁, k₂, h₁, h₂, hn, hP⟩ := this (B₁ + B₂) rfl.le,
    obtain ⟨rfl, rfl⟩ : k₁ = B₁ ∧ k₂ = B₂ := by split; linarith only [h₁, h₂, hn],
    exact hP, },
  intros n hn,
  induction n with n ih generalizing B₁ B₂ x y,
  { use [0, 0], simpa using hP_base x y, },
  by_cases H : (a + b).valid (x, y), swap,
  { -- Invalid
    obtain ⟨hvx, hvy⟩ : ¬a.valid x ∧ ¬b.valid y := by simpa [not_or_distrib] using H,
    refine ⟨B₁, B₂, rfl.le, rfl.le, hn, _⟩,
    exact hP_invalid _ _ _ _ _ H hvx hvy ha hb, },
  rcases lt_trichotomy (a.to_order x) (b.to_order y) with h|h|h, swap, rotate 1,
  { -- Advancing `a`
    have hvx : a.valid x := valid_of_le_or H h.le,
    cases B₁, { cases hvx.bound_pos ha, },
    rw [Stream.bound_valid_succ] at ha,
    obtain ⟨k₁, k₂, hk₁, hk₂, n_le, hP⟩ := ih (a.next _ hvx) y (ha hvx) hb (by simpa [nat.succ_eq_one_add, add_assoc] using hn),
    refine ⟨k₁ + 1, k₂, nat.succ_le_succ hk₁, hk₂, _, _⟩,
    { ac_change _ ≤ k₁ + k₂ + 1, exact nat.succ_le_succ n_le, },
    exact hP_advance_a _ _ _ _ _ hvx H h hP, },
  { -- Advancing `b`
    have hvy : b.valid y := valid_of_le_or (or.symm H) h.le,
    cases B₂, { cases hvy.bound_pos hb, },
    rw [Stream.bound_valid_succ] at hb,
    obtain ⟨k₁, k₂, hk₁, hk₂, n_le, hP⟩ := ih x (b.next _ hvy) ha (hb hvy) (nat.le_of_succ_le_succ hn),
    refine ⟨k₁, k₂ + 1, hk₁, nat.succ_le_succ hk₂, nat.succ_le_succ n_le, _⟩,
    exact hP_advance_b _ _ _ _ _ hvy H h hP, },
  { -- Advancing both `a` and `b`
    have hvx : a.valid x := valid_of_le_or H h.le,
    have hvy : b.valid y := valid_of_le_or (or.symm H) h.symm.le,
    cases B₁, { cases hvx.bound_pos ha, },
    cases B₂, { cases hvy.bound_pos hb, },
    have ha' := ha, rw nat.succ_eq_add_one at ha',
    rw [Stream.bound_valid_succ] at ha hb,
    obtain ⟨k₁, k₂, hk₁, hk₂, n_le, hP⟩ := ih (a.next _ hvx) (b.next _ hvy) ((ha hvx).mono B₁.le_succ) (hb hvy) (nat.le_of_succ_le_succ hn),
    refine ⟨min (B₁ + 1) (k₁ + 1), k₂ + 1, min_le_left _ _, nat.succ_le_succ hk₂, succ_le_min_succ_add_succ n_le hk₁, _⟩,
    exact hP_advance_both _ _ _ _ _ _ hvx hvy H ha' h hP, }
end

theorem Stream.add_spec [add_comm_monoid α] (a : Stream ι α) (b : Stream ι α) (x : a.σ) (y : b.σ)
  {B₁ B₂ : ℕ} (ha : a.bound_valid B₁ x) (hb : b.bound_valid B₂ y) :
  (a + b).eval_steps (B₁ + B₂) (x, y) = a.eval_steps B₁ x + b.eval_steps B₂ y :=
begin
  apply Stream.add_induction a b x y ha hb (λ x y k₁ k₂ N, (a + b).eval_steps N (x, y) = a.eval_steps k₁ x + b.eval_steps k₂ y); clear_except,
  { intros, simp, },
  { intros x y B₁ B₂ n H hvx hvy ha hb,
    simp [Stream.eval_invalid H, Stream.eval_invalid hvx, Stream.eval_invalid hvy], },
  { intros x y k₁ k₂ n hvx H h he,
    dsimp, simp [h.le, h.not_le, he, Stream.add.eval₀_left h hvx, H, hvx],
    apply add_right_comm, },
  { intros x y k₁ k₂ n hvy H h he,
    dsimp [nat.add_succ], simp [H, hvy, h.le, h.not_le, he, Stream.add_eval₀_right h hvy, add_assoc], },
  { intros x y k₁ k₂ B₁ n hvx hvy H ha h he,
    rw Stream.eval_min_bound ha,
    dsimp, simp [h.le, h.symm.le, he, Stream.add_eval₀_both h hvx hvy, H, hvx, hvy],
    abel, },
end

theorem Stream.add_spec_index [has_zero α] [has_add α] (a : Stream ι α) (b : Stream ι α) (x : a.σ) (y : b.σ)
  {B₁ B₂ : ℕ} (ha : a.bound_valid B₁ x) (hb : b.bound_valid B₂ y) :
  ((a + b).next'^[B₁ + B₂] (x, y)) = (a.next'^[B₁] x, b.next'^[B₂] y) :=
begin
  apply Stream.add_induction a b x y ha hb (λ x y k₁ k₂ N, ((a + b).next'^[N] (x, y)) = (a.next'^[k₁] x, b.next'^[k₂] y)); clear_except,
  { intros, simp, },
  { intros x y B₁ B₂ n H hvx hvy ha hb,
    simp [Stream.next'_val_invalid' H, Stream.next'_val_invalid' hvx, Stream.next'_val_invalid' hvy], },
  { intros x y k₁ k₂ n hvx H h hiter,
    simp [Stream.next'_val hvx, Stream.next'_val H, h.le, h.not_le, hiter], },
  { intros x y k₁ k₂ n hvy H h hiter,
    simp [Stream.next'_val hvy, Stream.next'_val H, h.le, h.not_le, hiter], },
  { intros x y k₁ k₂ B₁ n hvx hvy H ha h hiter,
    rw Stream.next'_min_bound ha,
    simp [h.le, h.symm.le, hiter, Stream.next'_val hvx, Stream.next'_val hvy, Stream.next'_val H], }
end

@[simps]
instance [has_zero α] [has_add α] : has_add (StreamExec ι α) := ⟨λ a b,
{ stream := a.stream + b.stream,
  state := (a.state, b.state),
  bound := a.bound + b.bound,
  bound_valid := begin
    rw [bound_valid_iff_next'_iterate], dsimp,
    simpa [bound_valid_iff_next'_iterate, (Stream.add_spec_index a.stream b.stream _ _ a.bound_valid b.bound_valid),
      not_or_distrib] using (and.intro a.bound_valid b.bound_valid),
  end }⟩

@[simp] lemma StreamExec.add_spec [add_comm_monoid α] (a : StreamExec ι α) (b : StreamExec ι α) :
  (a + b).eval = a.eval + b.eval := (Stream.add_spec a.stream b.stream _ _ a.bound_valid b.bound_valid)

lemma Stream.add_monotonic [has_zero α] [has_add α] {a : Stream ι α} {b : Stream ι α}
  (ha : a.monotonic) (hb : b.monotonic) :
  (a + b).monotonic :=
begin
  rintros ⟨x, y⟩ h,
  simp only [Stream.add_index'],
  refine min_le_min _ _,
  { simp, split_ifs, { exact ha _, }, exact rfl.le, },
  { simp, split_ifs, { exact hb _, }, exact rfl.le, },
end

lemma Stream.add_reduced [has_zero α] [has_add α] {a : Stream ι α} {b : Stream ι α}
  (ha : a.reduced) (hb : b.reduced) : (a + b).reduced :=
begin
  rintros ⟨x, y⟩ hv hr,
  rcases hr with ⟨h, hr⟩|⟨h, hr⟩;
  dsimp at hr h ⊢,
  { simp [h, (show min (a.index' x) (b.index' y) = _, from min_eq_left (prod.lex.fst_le_of_le h))],
    apply ne_min_of_ne_and_ne, { exact ha _ hr, },
    split_ifs with H,
    { obtain ⟨h₁, h₂⟩ : a.index' x = b.index' y ∧ (a.ready x ↔ b.ready y),
      { simpa [Stream.to_order] using (antisymm h H), },
      rw h₁, exact hb _ (by rwa ← h₂), },
    exact ne_of_lt (prod.lex.fst_lt_of_lt_of_le (lt_of_le_not_le h H) (by simp [hr])), },
  { simp [h, (show min (a.index' x) (b.index' y) = _, from min_eq_right (prod.lex.fst_le_of_le h))],
    apply ne_min_of_ne_and_ne, swap, { exact hb _ hr, },
    split_ifs with H,
    { obtain ⟨h₁, h₂⟩ : a.index' x = b.index' y ∧ (a.ready x ↔ b.ready y),
      { simpa [Stream.to_order] using (antisymm H h), },
      rw ← h₁, exact ha _ (by rwa h₂), },
    exact ne_of_lt (prod.lex.fst_lt_of_lt_of_le (lt_of_le_not_le h H) (by simp [hr])), },
end

instance StreamExec.AddZeroEval [add_comm_monoid α] : AddZeroEval (StreamExec ι α) ι α :=
{ hadd := StreamExec.add_spec,
  hzero := StreamExec.zero_eval }

lemma add_value_eval {ι α ι' α' : Type*} [linear_order ι] [add_comm_monoid α'] [AddZeroEval α ι' α']
  (a b : StreamExec ι α) :
  (Eval.eval <$₂> (a + b)) = (Eval.eval <$₂> a) + (Eval.eval <$₂> b) :=
begin
  ext; solve_refl,
  simp [apply_ite Eval.eval],
  congr; rw [Stream.bimap_value'_apply]; simp,
end

instance {ι α ι' α' : Type*} [linear_order ι] [add_comm_monoid α'] [AddZeroEval α ι' α'] :
  AddZeroEval (StreamExec ι α) ι (ι' →₀ α') :=
{ hadd := λ x y, by simp [Eval.eval, add_value_eval],
  hzero := StreamExec.zero_eval }

instance {ι : Type} {α : Type*} [linear_order ι] [has_zero α] [has_add α] : has_add (SimpleStream ι α) := ⟨λ a b,
{ simple :=
  { monotonic := Stream.add_monotonic a.monotonic b.monotonic,
    reduced := Stream.add_reduced a.reduced b.reduced },
  ..(@has_add.add (StreamExec ι α) _ a b) }⟩

instance SimpleStream.AddZeroEvalBase [add_comm_monoid α] : AddZeroEval (SimpleStream ι α) ι α :=
{ hadd := λ x y, by exact AddZeroEval.hadd (↑x : StreamExec _ _) (↑y : StreamExec _ _),
  hzero := SimpleStream.zero_eval }

instance SimpleStream.AddZeroEval {ι α ι' α' : Type*} [linear_order ι] [add_comm_monoid α'] [AddZeroEval α ι' α'] :
  AddZeroEval (SimpleStream ι α) ι (ι' →₀ α') :=
{ hadd := λ x y, by exact AddZeroEval.hadd (↑x : StreamExec _ _) (↑y : StreamExec _ _),
  hzero := SimpleStream.zero_eval }


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.category.Cat
import category_theory.elements

/-!
# The Grothendieck construction

Given a functor `F : C ⥤ Cat`, the objects of `grothendieck F`
consist of dependent pairs `(b, f)`, where `b : C` and `f : F.obj c`,
and a morphism `(b, f) ⟶ (b', f')` is a pair `β : b ⟶ b'` in `C`, and
`φ : (F.map β).obj f ⟶ f'`

Categories such as `PresheafedSpace` are in fact examples of this construction,
and it may be interesting to try to generalize some of the development there.

## Implementation notes

Really we should treat `Cat` as a 2-category, and allow `F` to be a 2-functor.

There is also a closely related construction starting with `G : Cᵒᵖ ⥤ Cat`,
where morphisms consists again of `β : b ⟶ b'` and `φ : f ⟶ (F.map (op β)).obj f'`.

## References

See also `category_theory.functor.elements` for the category of elements of functor `F : C ⥤ Type`.

* https://stacks.math.columbia.edu/tag/02XV
* https://ncatlab.org/nlab/show/Grothendieck+construction

-/

universe u

namespace category_theory

variables {C D : Type*} [category C] [category D]
variables (F : C ⥤ Cat)

/--
The Grothendieck construction (often written as `∫ F` in mathematics) for a functor `F : C ⥤ Cat`
gives a category whose
* objects `X` consist of `X.base : C` and `X.fiber : F.obj base`
* morphisms `f : X ⟶ Y` consist of
  `base : X.base ⟶ Y.base` and
  `f.fiber : (F.map base).obj X.fiber ⟶ Y.fiber`
-/
@[nolint has_inhabited_instance]
structure grothendieck :=
(base : C)
(fiber : F.obj base)

namespace grothendieck

variables {F}

/--
A morphism in the Grothendieck category `F : C ⥤ Cat` consists of
`base : X.base ⟶ Y.base` and `f.fiber : (F.map base).obj X.fiber ⟶ Y.fiber`.
-/
structure hom (X Y : grothendieck F) :=
(base : X.base ⟶ Y.base)
(fiber : (F.map base).obj X.fiber ⟶ Y.fiber)

@[ext] lemma ext {X Y : grothendieck F} (f g : hom X Y)
  (w_base : f.base = g.base) (w_fiber : eq_to_hom (by rw w_base) ≫ f.fiber = g.fiber) : f = g :=
begin
  cases f; cases g,
  congr,
  dsimp at w_base,
  induction w_base,
  refl,
  dsimp at w_base,
  induction w_base,
  simpa using w_fiber,
end

/--
The identity morphism in the Grothendieck category.
-/
@[simps]
def id (X : grothendieck F) : hom X X :=
{ base := 𝟙 X.base,
  fiber := eq_to_hom (by erw [category_theory.functor.map_id, functor.id_obj X.fiber]), }

instance (X : grothendieck F) : inhabited (hom X X) := ⟨id X⟩

/--
Composition of morphisms in the Grothendieck category.
-/
@[simps]
def comp {X Y Z : grothendieck F} (f : hom X Y) (g : hom Y Z) : hom X Z :=
{ base := f.base ≫ g.base,
  fiber :=
  eq_to_hom (by erw [functor.map_comp, functor.comp_obj]) ≫
    (F.map g.base).map f.fiber ≫ g.fiber, }

instance : category (grothendieck F) :=
{ hom := λ X Y, grothendieck.hom X Y,
  id := λ X, grothendieck.id X,
  comp := λ X Y Z f g, grothendieck.comp f g,
  comp_id' := λ X Y f,
  begin
    ext,
    { dsimp,
      -- We need to turn `F.map_id` (which is an equation between functors)
      -- into a natural isomorphism.
      rw ← nat_iso.naturality_2 (eq_to_iso (F.map_id Y.base)) f.fiber,
      simp,
      refl, },
    { simp, },
  end,
  id_comp' := λ X Y f, by ext; simp,
  assoc' := λ W X Y Z f g h,
  begin
    ext, swap,
    { simp, },
    { dsimp,
      rw ← nat_iso.naturality_2 (eq_to_iso (F.map_comp _ _)) f.fiber,
      simp,
      refl, },
  end, }

@[simp] lemma id_fiber' (X : grothendieck F) :
  hom.fiber (𝟙 X) = eq_to_hom (by erw [category_theory.functor.map_id, functor.id_obj X.fiber]) :=
id_fiber X

lemma congr {X Y : grothendieck F} {f g : X ⟶ Y} (h : f = g) :
  f.fiber = eq_to_hom (by subst h) ≫ g.fiber :=
by { subst h, dsimp, simp, }

section
variables (F)

/-- The forgetful functor from `grothendieck F` to the source category. -/
@[simps]
def forget : grothendieck F ⥤ C :=
{ obj := λ X, X.1,
  map := λ X Y f, f.1, }

end

universe w
variables (G : C ⥤ Type w)

/--
The Grothendieck construction applied to a functor to `Type`
(thought of as a functor to `Cat` by realising a type as a discrete category)
is the same as the 'category of elements' construction.
-/
def grothendieck_Type_to_Cat : grothendieck (G ⋙ Type_to_Cat) ≌ G.elements :=
{ functor :=
  { obj := λ X, ⟨X.1, X.2⟩,
    map := λ X Y f, ⟨f.1, f.2.1.1⟩ },
  inverse :=
  { obj := λ X, ⟨X.1, X.2⟩,
    map := λ X Y f, ⟨f.1, ⟨⟨f.2⟩⟩⟩ },
  unit_iso := nat_iso.of_components (λ X, by { cases X, exact iso.refl _, })
    (by { rintro ⟨⟩ ⟨⟩ ⟨base, ⟨⟨f⟩⟩⟩, dsimp at *, subst f, simp, }),
  counit_iso := nat_iso.of_components (λ X, by { cases X, exact iso.refl _, })
    (by { rintro ⟨⟩ ⟨⟩ ⟨f, e⟩, dsimp at *, subst e, simp }),
  functor_unit_iso_comp' := by { rintro ⟨⟩, dsimp, simp, refl, } }

end grothendieck

end category_theory


import lambda_calculus.utlc.beta.distance
import lambda_calculus.utlc.beta.encoding.basic
import lambda_calculus.utlc.beta.encoding.core
import lambda_calculus.utlc.beta.encoding.list
import lambda_calculus.utlc.beta.complexity.core
import complexity.basic
import complexity.nat

open complexity
open lambda_calculus.utlc.β.encoding

namespace lambda_calculus
namespace utlc
namespace β
namespace complexity
namespace list
local attribute [simp] β.normal_iteration β.strategic_reduction_step
local attribute [simp] down_shift head_reduced
local attribute [simp] complexity.cast_unwrap distance_model

-- def cons_prog: encoded_program := ⟨ (Λ Λ Λ Λ ↓0·↓3·↓2), by simp[← one_add_one_eq_two] ⟩

-- instance cons_complexity
--   (α: Type) [complexity.has_encoding distance_model α]:
--   complexity.has_complexity distance_model (@list.cons α) :=
--   ⟨ ⟨ (λ _ _, (2:ℕ)), ⟨ cons_prog, λ x xs, distance_le_of_normal_iteration _
--     (by simp [cons_prog, has_encoding.value, encoding.list.encode_list, encode]) ⟩ ⟩ ⟩

-- def handle_nil (f y: utlc): utlc := f
-- def handle_cons (f y: utlc): utlc := Λ Λ (f ↑¹ 0 ↑¹ 1)·↓1·↓0·((y ↑¹ 0 ↑¹ 1)·↓0)
-- def fold_cons (f y: utlc): utlc := Λ Λ ((y ↑¹ 0 ↑¹ 1)·((f ↑¹ 0 ↑¹ 1)·↓1·↓0)·↓0)
-- def rec_list (y g f₀ f₁: utlc): utlc := g·handle_nil f₀ y·handle_cons f₁ y

-- section
-- local notation a `[` b `:=` c  `]` : 70 := has_substitution.substitution a b c

-- theorem rec_list_sub {y g f₀ f₁: utlc} (n: ℕ) (x: utlc):
--   (rec_list y g f₀ f₁)[n:=x] = (rec_list (y[n:=x]) (g[n:=x]) (f₀[n:=x]) (f₁[n:=x])) :=
-- begin
--   simp [rec_list, handle_nil, handle_cons, substitution_shift_ge],
--   repeat { rw [substitution_shift_ge] },
--   all_goals { linarith },
-- end

-- theorem rec_list_nil {α: Type} [α_en: complexity.has_encoding distance_model α]
--   (y: utlc) (f₀ f₁: utlc):
--   distance_le 2
--     (rec_list y (encoding.list.encode_list (@list.nil α)).value f₀ f₁)
--     f₀ :=
-- begin
--   rw [rec_list, list.encode_list, β.encoding.alternative],
--   simp,
--   apply distance_le_of_normal_iteration,
--   simp [handle_nil],
-- end

-- theorem rec_list_cons {α: Type} [α_en: complexity.has_encoding distance_model α]
--   (y: utlc) (x: α) (xs: list α) (f₀ f₁: utlc):
--   distance_le 4
--     (rec_list y (encoding.list.encode_list (x :: xs)).value f₀ f₁)
--     (f₁·(complexity.encode distance_model x).value·(complexity.encode distance_model xs).value·(y·(complexity.encode distance_model xs).value)) :=
-- begin
--   rw [rec_list, list.encode_list, β.encoding.alternative],
--   apply distance_le_of_normal_iteration,
--   simp [handle_cons, complexity.encode, has_encoding.value],
-- end
-- end

-- namespace foldl_complexity

-- def cost {α: Type} {β: Type}
--   (rf: α → β → α)
--   (c_nil: ℕ) (c_cons: α → β → ℕ):
--   α → list β → ℕ :=
--   λ a xs, (list.foldl (λ (ca: ℕ × α) b, (ca.fst + c_cons ca.snd b, rf ca.snd b)) ((0:ℕ), a) xs).fst

-- | ([]) a := c_nil
-- | (x :: xs) a := c_cons a x + cost xs (rf a x)
-- end foldl_complexity

-- instance foldl_complexity
--   (α β: Type) [has_encoding distance_model α] [has_encoding distance_model β]
--   (f: α → β → α) [cf: has_complexity distance_model f]:
--   has_complexity distance_model (list.foldl f) :=
-- begin
--   fconstructor,
--   fconstructor,
--   exact (foldl_complexity.cost f 0 cf.value.cost),
--   rcases cf.value with ⟨cfc, fp, cfp⟩,
--   fconstructor,
--   fconstructor,
--   exact (yrec

-- end

end list
end complexity
end β
end utlc
end lambda_calculus


import for_mathlib.category_theory.triangulated.shift_compatibility
import for_mathlib.category_theory.triangulated.pretriangulated_misc
import category_theory.preadditive.opposite
import for_mathlib.category_theory.preadditive.misc
import tactic.abel

noncomputable theory

universe u

open category_theory category_theory.category category_theory.limits

namespace category_theory

variables {C : Type*} {A B : Type u} [category C] [add_monoid A] [add_monoid B]
  {G : Type*} [add_comm_group G]

local attribute [instance, reducible] endofunctor_monoidal_category
local attribute [reducible] discrete.add_monoidal

variables (C A)

def has_shift_op [has_shift C A] : has_shift Cᵒᵖ A :=
has_shift_mk _ _
{ F := λ a, (shift_functor C a).op,
  ε := (functor.op_unop_equiv C C).functor.map_iso (shift_functor_zero C A).op,
  μ := λ a b, (functor.op_unop_equiv C C).functor.map_iso (shift_functor_add C a b).op,
  associativity := λ a b c X, quiver.hom.unop_inj begin
    have eq := congr_arg iso.inv (monoidal_functor.associativity_iso_eq (shift_monoidal_functor C A)
      (discrete.mk a) (discrete.mk b) (discrete.mk c)),
    replace eq := congr_app eq (opposite.unop X),
    dsimp at ⊢ eq,
    erw [comp_id, id_comp, functor.map_id, functor.map_id, comp_id] at eq,
    simpa only [← eq, eq_to_hom_unop, eq_to_hom_map, eq_to_hom_app],
  end,
  left_unitality := λ a X, quiver.hom.unop_inj begin
    dsimp,
    simpa only [obj_ε_inv_app, eq_to_iso.hom, μ_inv_hom_app_assoc, eq_to_hom_unop,
      eq_to_hom_map, eq_to_hom_app],
  end,
  right_unitality := λ a X, quiver.hom.unop_inj begin
    dsimp,
    simpa only [ε_inv_app_obj, eq_to_iso.hom, μ_inv_hom_app_assoc, eq_to_hom_unop,
      eq_to_hom_map, eq_to_hom_app],
  end, }

variable {A}

def has_shift_pull [has_shift C B] (φ : A →+ B) : has_shift C A :=
⟨monoidal_functor.comp (discrete.add_monoidal_functor φ) (shift_monoidal_functor C B)⟩

variable {C}

def has_shift.op (s : has_shift C A) : has_shift Cᵒᵖ A :=
by { letI := s, apply has_shift_op, }

def has_shift.pull (s : has_shift C B) (φ : A →+ B) : has_shift C A :=
by { letI := s, exact has_shift_pull C φ, }

def has_shift.op_neg (s : has_shift C G) :
  has_shift Cᵒᵖ G :=
s.op.pull (⟨λ g, -g, by tidy, λ x y, by abel⟩ : G →+ G)

variables (C G)

def has_shift_op_neg [has_shift C G] : has_shift Cᵒᵖ G :=
has_shift.op_neg infer_instance

def has_shift_op_neg_ℤ [has_shift C ℤ] : has_shift Cᵒᵖ ℤ :=
has_shift.op_neg infer_instance

namespace pretriangulated

variables (C) [has_shift C ℤ]

local attribute [instance] has_shift_op_neg_ℤ

lemma _root_.category_theory.shift_functor_op_map
  {X Y : Cᵒᵖ} (f : X ⟶ Y) (n : ℤ) :
  (shift_functor Cᵒᵖ n).map f = ((shift_functor C (-n)).map f.unop).op := rfl

variable [preadditive C]

namespace triangle_op_equivalence

@[simps]
def functor : (triangle C)ᵒᵖ ⥤ triangle Cᵒᵖ :=
{ obj := λ T,
  { obj₁ := opposite.op T.unop.obj₃,
    obj₂ := opposite.op T.unop.obj₂,
    obj₃ := opposite.op T.unop.obj₁,
    mor₁ := T.unop.mor₂.op,
    mor₂ := T.unop.mor₁.op,
    mor₃ := ((shift_equiv C (1 : ℤ)).unit_iso.inv.app T.unop.obj₁).op ≫
      (T.unop.mor₃⟦(-1 : ℤ)⟧').op, },
  map := λ T₁ T₂ f,
  { hom₁ := f.unop.hom₃.op,
    hom₂ := f.unop.hom₂.op,
    hom₃ := f.unop.hom₁.op,
    comm₁' := quiver.hom.unop_inj f.unop.comm₂.symm,
    comm₂' := quiver.hom.unop_inj f.unop.comm₁.symm,
    comm₃' := quiver.hom.unop_inj begin
      dsimp only,
      have h := (shift_equiv C (1 : ℤ)).unit_iso.inv.naturality f.unop.hom₁,
      simp only [category_theory.shift_functor_op_map, unop_comp, quiver.hom.unop_op, assoc],
      erw ← (shift_equiv C (1 : ℤ)).unit_iso.inv.naturality f.unop.hom₁,
      dsimp only [shift_equiv, functor.comp_map],
      simp only [← assoc, ← functor.map_comp, f.unop.comm₃],
    end, }, }

@[simps]
def inverse : triangle Cᵒᵖ ⥤ (triangle C)ᵒᵖ :=
{ obj := λ T, opposite.op
  { obj₁ := T.obj₃.unop,
    obj₂ := T.obj₂.unop,
    obj₃ := T.obj₁.unop,
    mor₁ := T.mor₂.unop,
    mor₂ := T.mor₁.unop,
    mor₃ := (shift_equiv C (1 : ℤ)).counit_iso.inv.app T.obj₁.unop ≫ T.mor₃.unop⟦(1 : ℤ)⟧', },
  map := λ T₁ T₂ f, quiver.hom.op
  { hom₁ := f.hom₃.unop,
    hom₂ := f.hom₂.unop,
    hom₃ := f.hom₁.unop,
    comm₁' := quiver.hom.op_inj f.comm₂.symm,
    comm₂' := quiver.hom.op_inj f.comm₁.symm,
    comm₃' := begin
      dsimp only,
      have h := functor.congr_map (shift_functor C (1 : ℤ)) (congr_arg quiver.hom.unop f.comm₃),
      simp only [unop_comp, functor.map_comp] at h,
      simp only [assoc, ← h],
      erw ← nat_trans.naturality_assoc,
      refl,
    end, }, }

@[simps]
def unit_iso : 𝟭 _ ≅ functor C ⋙ inverse C :=
nat_iso.of_components (λ T, begin
  refine iso.op (_ : opposite.unop _ ≅ opposite.unop T),
  refine triangle.mk_iso _ _ (iso.refl _) (iso.refl _) (iso.refl _) (by tidy) (by tidy) _,
  dsimp only [iso.refl],
  rw [functor.map_id, comp_id, id_comp],
  change (shift_equiv C (1 : ℤ)).counit_iso.inv.app T.unop.obj₃ ≫
    (shift_functor C (1 : ℤ)).map (((shift_functor C (-1 : ℤ)).map T.unop.mor₃) ≫
      ((shift_equiv C (1 : ℤ)).unit_iso.inv.app T.unop.obj₁)) = T.unop.mor₃,
  erw [functor.map_comp, (shift_equiv C (1 : ℤ)).fun_inv_map],
  simp only [assoc],
  erw (shift_equiv C (1 : ℤ)).counit_inv_functor_comp,
  erw comp_id,
  erw iso.inv_hom_id_app_assoc,
end) (λ X Y f, quiver.hom.unop_inj (by tidy))

@[simps]
def counit_iso : inverse C ⋙ functor C ≅ 𝟭 _ :=
nat_iso.of_components (λ T, begin
  refine triangle.mk_iso _ _ (iso.refl _) (iso.refl _) (iso.refl _)
    (by tidy) (by tidy) (quiver.hom.unop_inj _),
  dsimp only [iso.refl],
  rw [functor.map_id, id_comp, comp_id],
  change ((shift_equiv C (1 : ℤ)).counit_iso.inv.app (opposite.unop T.obj₁) ≫
    T.mor₃.unop⟦(1 : ℤ)⟧')⟦(-1 : ℤ)⟧' ≫
    ((shift_equiv C (1 : ℤ)).unit_iso.inv.app T.obj₃.unop) = T.mor₃.unop,
  erw [functor.map_comp, (shift_equiv C (1 : ℤ)).inv_fun_map],
  simp only [assoc, iso.hom_inv_id_app],
  erw comp_id,
  slice_lhs 1 2 { erw (shift_equiv C (1 : ℤ)).inverse_counit_inv_comp, },
  erw id_comp,
end) (by tidy)

end triangle_op_equivalence

@[simps]
def triangle_op_equivalence : (triangle C)ᵒᵖ ≌ triangle Cᵒᵖ :=
{ functor := triangle_op_equivalence.functor C,
  inverse := triangle_op_equivalence.inverse C,
  unit_iso := triangle_op_equivalence.unit_iso C,
  counit_iso := triangle_op_equivalence.counit_iso C, }

variable {C}

def triangle.op (T : triangle C) : triangle Cᵒᵖ :=
(triangle_op_equivalence C).functor.obj (opposite.op T)

def triangle.unop (T : triangle Cᵒᵖ) : triangle C :=
((triangle_op_equivalence C).inverse.obj T).unop

def triangle.unop_op (T : triangle C) : T.op.unop ≅ T :=
((triangle_op_equivalence C).unit_iso.app (opposite.op T)).unop

def triangle.op_unop (T : triangle Cᵒᵖ) : T.unop.op ≅ T :=
(triangle_op_equivalence C).counit_iso.app T

variables [∀ (n : ℤ), (shift_functor C n).additive]

instance shift_functor_op_additive (n : ℤ) : (shift_functor Cᵒᵖ n).additive :=
(infer_instance : (shift_functor C (-n)).op.additive)

def triangle.unop_rotate (T : triangle Cᵒᵖ) : T.rotate.unop ≅ T.unop.inv_rotate :=
begin
  refine triangle.mk_iso _ _ (preadditive.mul_iso (-1) (iso.refl _)) (iso.refl _) (iso.refl _) _ _ _,
  { change T.mor₃.unop ≫ 𝟙 _ = ((-1 : ℤ) • 𝟙 _) ≫
      -((shift_equiv C (1 : ℤ)).counit_iso.inv.app T.obj₁.unop ≫ T.mor₃.unop⟦(1 : ℤ)⟧')⟦(-1:ℤ)⟧' ≫
      (shift_equiv C (1 : ℤ)).unit_iso.inv.app T.obj₃.unop,
    simp only [comp_id, neg_smul, one_smul, preadditive.comp_neg, preadditive.neg_comp, neg_neg,
      id_comp, functor.map_comp, assoc],
    erw (shift_equiv C (1 : ℤ)).inv_fun_map,
    slice_rhs 1 2 { erw (shift_equiv C (1 : ℤ)).inverse_counit_inv_comp, },
    simp only [assoc, iso.hom_inv_id_app],
    erw [id_comp, comp_id], },
  { dsimp only [iso.refl],
    rw [id_comp, comp_id],
    refl, },
  { change ((shift_equiv C (1 : ℤ)).counit_iso.inv.app T.obj₂.unop ≫
      (-(T.mor₁).unop⟦(-1 : ℤ)⟧')⟦(1 : ℤ)⟧') ≫ ((-1 : ℤ) • 𝟙 _)⟦(1 : ℤ)⟧' =
        𝟙 _ ≫ T.mor₁.unop ≫ (shift_equiv C (1 : ℤ)).counit_iso.inv.app T.obj₁.unop,
    simp only [functor.map_neg, neg_smul, one_smul, functor.map_id, preadditive.comp_neg,
      preadditive.neg_comp, neg_neg, comp_id, id_comp],
    erw ← nat_trans.naturality,
    refl, },
end

end pretriangulated

end category_theory


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad

The syntax of simple type theory, i.e. inductive definitions of types and terms.

Notes:

When it comes to basic types, type constructors, and constants, we distinguish between "built in"
and "user" objects. The former are fixed for the implementation, and the implementation can refer
to them directly (for example, logical connectives, arithmetic symbols, types like nat and bool,
and type constructors like list, sum, and prod).

TODO: Factor out types for constants, basic types, etc. These can include more information
about the environment, source, pretty-printing, etc.

TODO: We do not have "local_constants". It is probably best to have these as special sorts of
constants, but we can revisit this decision.

TODO: For now, we won't handle polymorphic types, though we will eventually (mostly following
HOL light).

TODO: For now, use naive equality tests. We can worry about more efficient tests (e.g. with
unique id's) later, if necessary.

TODO: if we replace each `= tt` by a coercion to bool, things break in some places. They are
fixable, but then something more dramatic breaks in fol.syntax and the terms are huge.
-/
import data.list

/- TODO: move these -/

@[simp]
theorem if_neg_eq {α : Type*} (p : Prop) [decidable p] (a b : α) :
  (if ¬ p then a else b) = (if p then b else a) :=
begin
  by_cases h : p; simp [h],
end

theorem to_bool_eq_to_bool (p q : Prop) [decidable p] [decidable q] :
  (to_bool p = to_bool q) ↔ (p ↔ q) :=
by by_cases p; simp [h]

namespace list

@[simp]
theorem not_cons_prefix_nil {α : Type*} (a : α) (l : list α) : ¬ a :: l <+: nil :=
by { unfold is_prefix, intro h, cases h, contradiction }

@[simp]
theorem cons_prefix_cons {α : Type*} (a₁ a₂ : α) (l₁ l₂ : list α) :
  a₁ :: l₁ <+: a₂ :: l₂ ↔ a₁ = a₂ ∧ l₁ <+: l₂ :=
begin
  unfold is_prefix,
  split; intro h,
  { cases h with l h, split, apply head_eq_of_cons_eq h, existsi l, apply tail_eq_of_cons_eq h},
  cases h with h₀ h₁, cases h₁ with l h₁,
  existsi l, rw [h₀, ← h₁], simp
end

theorem length_le_of_prefix {α : Type*} {l₁ l₂ : list α} (h : l₁ <+: l₂) : length l₁ ≤ length l₂ :=
length_le_of_sublist $ sublist_of_prefix h

theorem prefix_iff_eq_of_length_eq {α : Type*} {l₁ l₂ : list α} (h : length l₁ = length l₂) :
  l₁ <+: l₂ ↔ (l₁ = l₂) :=
by { split, { intro h', exact eq_of_prefix_of_length_eq h' h}, intro h', rw h'}

theorem drop_succ {α : Type*} (n : nat) (l : list α) : drop n.succ l = drop n (drop 1 l) :=
by induction l; simp

theorem drop_eq_nil  {α : Type*} (n : nat) (l : list α) : drop n l = [] ↔ n ≥ l.length:=
begin
  revert n,
  induction l with a l ih; simp,
  { apply nat.zero_le },
  intro n, cases n with n; simp,
  { rw add_comm, apply nat.zero_lt_succ },
  rw ih, rw [add_comm, ge, ge, nat.succ_le_succ_iff]
end

end list

namespace hol

/-
Instead of option, we'll have failure produce error messages. But we will not use the full-blown
exception monad or do anything fancy, to make it easier to reason about these programs.

TODO: not using this yet.
-/

inductive except (α : Type*)
| ok   : α → except
| fail : string → except

/-
    Types
-/

namespace type

  /- basic types -/

  @[derive has_reflect, derive decidable_eq]
  inductive basic : Type
  | user : ℕ → basic
  | prop
  | nat
  | int
  | bool
  | unit

  namespace basic
    def repr : basic → string
    | (user n) := "(basic.user " ++ n.repr ++ ")"
    | prop := "basic.prop"
    | nat  := "basic.nat"
    | int  := "basic.int"
    | bool := "basic.bool"
    | unit := "basic.unit"

    instance : has_repr basic := ⟨repr⟩
  end basic

  /- type constructors -/

  namespace constructor
    @[derive has_reflect, derive decidable_eq]
    inductive kind
    | user : nat → kind
    | list
    | prod
    | sum
  end constructor

  @[derive has_reflect, derive decidable_eq]
  structure constructor :=
  (symb : constructor.kind) (arity : nat)

  namespace constructor
    def user (n arity : nat)  : constructor := ⟨kind.user n, arity⟩
    def list : constructor := ⟨kind.list, 1⟩
    def prod : constructor := ⟨kind.prod, 2⟩
    def sum : constructor := ⟨kind.sum, 2⟩

    def repr : constructor → string
    | ⟨kind.user n, a⟩ := "(constructor.user " ++ n.repr ++ " " ++ a.repr ++")"
    | ⟨kind.list, _⟩   := "constructor.list"
    | ⟨kind.prod, _⟩   := "constructor.list"
    | ⟨kind.sum, _⟩    := "constructor.list"

    instance : has_repr constructor := ⟨repr⟩
  end constructor

end type

/-
The types themselves

Notes:

To avoid a nested inductive type, we'll use iterated application for constructors.

Basic and arrow types are really special cases of constructors, but we'll keep them separate.
-/

@[derive has_reflect, derive decidable_eq]
inductive type
| Var         : nat → type
| Basic       : hol.type.basic → type
| Arr         : type → type → type
| Constructor : hol.type.constructor → type
| App         : type → type → type

namespace type

def repr : type → string
| (Var n)         := "(Var " ++ n.repr ++ ")"
| (Basic b)       := "(Basic " ++ b.repr ++ ")"
| (Arr t₁ t₂)     := "(Arr " ++ t₁.repr ++ " " ++ t₂.repr ++")"
| (Constructor c) := "(Constructor " ++ c.repr ++ ")"
| (App t₁ t₂)     := "(App " ++ t₁.repr ++ " " ++ t₂.repr ++ ")"

instance : has_repr type := ⟨repr⟩

-- `arities_ok t l` says the type `t` iteratively applied to `l` makes sense
def arities_ok_aux : type → list type → bool
| (Var n)         l := l.empty
| (Basic b)       l := l.empty
| (Arr t₁ t₂)     l := arities_ok_aux t₁ l && arities_ok_aux t₂ l && l.empty
| (Constructor c) l := c.arity = l.length
| (App t₁ t₂)     l := arities_ok_aux t₂ [] && arities_ok_aux t₁ (t₂ :: l)

def arities_ok (t : type) : bool := arities_ok_aux t []

/-- Returns the domain of an arrow type, or the type itself if it is not an arrow. -/
@[simp]
def domain : type → type
| (type.Arr t₁ t₂) := t₁
| t                := t

/-- Returns the codomain of an arrow type, or the type itself if it is not an arrow. -/
@[simp]
def codomain : type → type
| (type.Arr t₁ t₂) := t₂
| t                := t

@[simp]
def get_arg_types : type → list type
| (type.Arr t₁ t₂) := t₁ :: get_arg_types t₂
| _                := []

@[simp]
def num_arg_types : type → nat
| (type.Arr t₁ t₂) := num_arg_types t₂ + 1
| _                := 0

lemma length_get_arg_types (t : type) : t.get_arg_types.length = t.num_arg_types :=
by induction t; simp [*]

@[simp]
def get_return_type : type → type
| (type.Arr t₁ t₂) := get_return_type t₂
| t                := t

@[simp]
def mk_fn_type : list type → type → type
| []        ret := ret
| (a :: as) ret := (type.Arr a (mk_fn_type as ret))

theorem mk_fn_type_eq (t : type) : t = mk_fn_type (get_arg_types t) (get_return_type t) :=
by { induction t; simp [get_arg_types, get_return_type, mk_fn_type], assumption }

@[simp]
theorem get_return_type_codomain (t : type) : get_return_type (t.codomain) = get_return_type t :=
by induction t; simp

theorem get_arg_types_codomain (t : type) : get_arg_types (t.codomain) = t.get_arg_types.drop 1 :=
by induction t; simp

@[simp]
def is_arrow : type → bool
| (Arr t₁ t₂) := tt
| _           := ff

theorem is_arrow_mk_fn_type (ts : list type) (t : type) (h : t.is_arrow = ff) :
  (mk_fn_type ts t).is_arrow = (ts ≠ []) :=
by induction ts; simp [h]

theorem is_arrow_get_return_type_eq_ff (t : type) : t.get_return_type.is_arrow = ff :=
by induction t; simp [*]

theorem eq_of_is_arrow (t : type) (h : is_arrow t = tt) : t = Arr (domain t) (codomain t) :=
by cases t; simp at h; trivial

lemma cons_prefix_get_arg_types (ty ty' : type) (tys : list type) :
  (ty :: tys) <+: ty'.get_arg_types ↔
    is_arrow ty' = tt ∧ ty = ty'.domain ∧ tys <+: ty'.codomain.get_arg_types :=
by cases ty'; simp

end type

/- convenient type constructors -/

section
open type

-- TODO: mark these as reducible?

def mk_prop := Basic basic.prop
def mk_nat := Basic basic.nat
def mk_int := Basic basic.int
def mk_unit := Basic basic.int
def mk_bool := Basic basic.bool
def mk_user_type (n : ℕ) := Basic (basic.user n)

def mk_list_type (t : type) : type := App (Constructor constructor.list) t
def mk_prod_type (t₁ t₂ : type) : type := App (App (Constructor constructor.prod) t₁) t₂
def mk_sum_type (t₁ t₂ : type) : type := App (App (Constructor constructor.sum) t₁) t₂

--notation t₁ ` ⇒ `:65 t₂ := Arr t₁ t₂
infixr ` ⇒ ` := Arr

theorem arities_ok_mk_prop : arities_ok mk_prop :=
by simp [mk_prop, arities_ok, arities_ok_aux, list.empty]

theorem arities_ok_mk_nat : arities_ok mk_nat :=
by simp [mk_nat, arities_ok, arities_ok_aux, list.empty]

theorem arities_ok_mk_int : arities_ok mk_int :=
by simp [mk_int, arities_ok, arities_ok_aux, list.empty]

theorem arities_ok_mk_list_type (t : type) (h : arities_ok t = tt) :
  arities_ok (mk_list_type t) = tt :=
by { simp [arities_ok] at *, simp [mk_list_type, arities_ok_aux, h, constructor.list] }

theorem arities_ok_mk_prod_type (t₁ t₂ : type)
    (h₁ : arities_ok t₁ = tt) (h₂ : arities_ok t₂ = tt) :
  arities_ok (mk_prod_type t₁ t₂) = tt :=
by { simp [arities_ok] at *, simp [mk_prod_type, arities_ok_aux, h₁, h₂, constructor.prod] }

theorem arities_ok_mk_sum_type (t₁ t₂ : type)
    (h₁ : arities_ok t₁ = tt) (h₂ : arities_ok t₂ = tt) :
  arities_ok (mk_sum_type t₁ t₂) = tt :=
by { simp [arities_ok] at *, simp [mk_sum_type, arities_ok_aux, h₁, h₂, constructor.sum] }

end

/-
    Terms
-/

namespace term

  /- constants -/

  namespace const
    @[derive has_reflect, derive decidable_eq]
    inductive kind
    | user : nat → kind
    | true
    | false
    | not
    | and
    | or
    | implies
    | iff
    | all
    | ex
    | add
    | mul
    | sub
    | bval : bool → kind
    | nval : nat → kind
  end const

  -- instantiations are for polymorphic constants
  @[derive has_reflect, derive decidable_eq]
  structure const :=
  (symb : const.kind) (type : type) (insts : list hol.type)

  namespace const
    def user (n : nat) (t : hol.type) (l : list hol.type) : const := ⟨kind.user n, t, l⟩
    def true : const := ⟨kind.true, mk_prop, []⟩
    def false : const := ⟨kind.false, mk_prop, []⟩
    def not : const := ⟨kind.not, mk_prop ⇒ mk_prop, []⟩
    def and : const := ⟨kind.and, mk_prop ⇒ (mk_prop ⇒ mk_prop), []⟩
    def or : const := ⟨kind.or, mk_prop ⇒ (mk_prop ⇒ mk_prop), []⟩
    def implies : const := ⟨kind.implies, mk_prop ⇒ (mk_prop ⇒ mk_prop), []⟩
    def iff : const := ⟨kind.iff, mk_prop ⇒ (mk_prop ⇒ mk_prop), []⟩
    def add : const := ⟨kind.add, mk_nat ⇒ (mk_nat ⇒ mk_nat), []⟩
    def mul : const := ⟨kind.mul, mk_nat ⇒ (mk_nat ⇒ mk_nat), []⟩
    def sub : const := ⟨kind.sub, mk_nat ⇒ (mk_nat ⇒ mk_nat), []⟩
    def tt  : const := ⟨kind.bval tt, mk_bool, []⟩
    def ff  : const := ⟨kind.bval ff, mk_bool, []⟩
    def nval (n : nat) : const := ⟨kind.nval n, mk_nat, []⟩

    def repr : const → string
    | ⟨kind.user n, t, l⟩       := "(const.user " ++ n.repr ++ " " ++ t.repr ++ " " ++
                                      l.repr ++ ")"
    | ⟨kind.true, _, _⟩         := "const.true"
    | ⟨kind.false, _, _⟩        := "const.false"
    | ⟨kind.not, _, _⟩          := "const.not"
    | ⟨kind.and, _, _⟩          := "const.and"
    | ⟨kind.or, _, _⟩           := "const.or"
    | ⟨kind.implies, _, _⟩      := "const.implies"
    | ⟨kind.iff, _, _⟩          := "const.iff"
    | ⟨kind.all, _, _⟩          := "const.all"
    | ⟨kind.ex, _, _⟩           := "const.ex"
    | ⟨kind.add, _, _⟩          := "const.add"
    | ⟨kind.mul, _, _⟩          := "const.mul"
    | ⟨kind.sub, _, _⟩          := "const.sub"
    | ⟨kind.bval bool.tt, _, _⟩ := "const.tt"
    | ⟨kind.bval bool.ff, _, _⟩ := "const.ff"
    | ⟨kind.nval n, _, _⟩       := "(const.nval " ++ n.repr ++ ")"

    instance : has_repr const := ⟨repr⟩

    -- TODO: delete this?
    def is_connective : const → bool
    | ⟨kind.true, t, l⟩         := if t = mk_prop then l.empty else bool.ff
    | ⟨kind.false, t, l⟩        := if t = mk_prop then l.empty else bool.ff
    | ⟨kind.not, t, l⟩          := if t = (mk_prop ⇒ mk_prop) then l.empty else bool.ff
    | ⟨kind.and, t, l⟩          := if t = (mk_prop ⇒ mk_prop ⇒ mk_prop) then l.empty else bool.ff
    | ⟨kind.or, t, l⟩           := if t = (mk_prop ⇒ mk_prop ⇒ mk_prop) then l.empty else bool.ff
    | ⟨kind.implies, t, l⟩      := if t = (mk_prop ⇒ mk_prop ⇒ mk_prop) then l.empty else bool.ff
    | ⟨kind.iff, t, l⟩          := if t = (mk_prop ⇒ mk_prop ⇒ mk_prop) then l.empty else bool.ff
    | _                         := bool.ff
  end const

end term

/- the terms themselves -/

@[derive has_reflect, derive decidable_eq]
inductive term
| Var     : nat → term
| Const   : hol.term.const → term
| App     : term → term → term                -- application
| Abs     : string → hol.type → term → term   -- the string gives the preferred name

namespace term

-- TODO: not needed?
def sizeof' : term → nat
| (Var n)      := 0
| (Const n)    := 0
| (App s t)    := sizeof' s + sizeof' t + 1
| (Abs s ty t) := sizeof t + 1

instance : has_sizeof term := ⟨sizeof'⟩

def repr : term → string
| (Var n)      := "(Var " ++ n.repr ++ ")"
| (Const c)    := "(Const " ++ c.repr ++ ")"
| (App t₁ t₂)  := "(App " ++ t₁.repr ++ t₂.repr ++ ")"
| (Abs s ty t) := "(Abs " ++ _root_.repr s ++ " " ++ ty.repr ++ " " ++ t.repr ++ ")"

@[simp]
def is_var : term → bool
| (Var n) := tt
| _       := ff

def var_num : term → nat
| (Var n) := n
| _       := 0

@[simp]
def is_const : term → bool
| (Const c) := tt
| _         := ff

@[simp]
def is_app : term → bool
| (App f a) := tt
| _         := ff

def app_fn : term → term
| (App f a) := f
| t         := t

def app_arg : term → term
| (App f a) := a
| t         := t

@[simp]
def get_app_fn : term → term
| (App f a) := get_app_fn f
| t          := t

def get_app_num_args : term → ℕ
| (App f a) := get_app_num_args f + 1
| t         := 0

def get_app_args_aux : term → list term → list term
| (App t₁ t₂)  args := get_app_args_aux t₁ (t₂ :: args)
| (Var n)      args := args
| (Const c)    args := args
| (Abs s ty t) args := args

def get_app_args (t : term) : list term := get_app_args_aux t []

@[simp]
def mk_app : term → list term → term
| t []       := t
| t (a::as)  := mk_app (App t a) as

theorem mk_app_get_app_aux (t : term) :
  ∀ as, mk_app (get_app_fn t) (get_app_args_aux t as) = mk_app t as :=
by induction t; simp [get_app_fn, get_app_args_aux, mk_app, *]

theorem mk_app_get_app (t : term) : mk_app (get_app_fn t) (get_app_args t) = t :=
by simp [get_app_args, mk_app_get_app_aux, mk_app]

theorem not_is_app_get_app_fn (t : term) : is_app t.get_app_fn = ff :=
by { induction t with _ _ _ _ ih; simp, exact ih }

/-- Infers the type of a term, given an assignment to free variables. Assumes the expression is
    well-typed-/
def typeof : term → list type → type
| (Var n) σ       := if h : n < σ.length then σ.nth_le n h else mk_nat
| (Const c) σ     := c.type
| (App t₁ t₂) σ   := (typeof t₁ σ).codomain
| (Abs s ty t) σ  := ty ⇒ typeof t (ty :: σ)

inductive is_well_typed : term → list type → Prop
| wt_var (n : ℕ) (σ : list type) (h : n < σ.length)      : is_well_typed (Var n) σ
| wt_const (c : const) (σ : list type)                   : is_well_typed (Const c) σ
| wt_app (t₁ t₂ : term) (σ : list type)
    (h₁ : is_well_typed t₁ σ)
    (h₂ : is_well_typed t₂ σ)
    (h₃ : (typeof t₁ σ).is_arrow = tt)
    (h₄ : (typeof t₁ σ).domain = typeof t₂ σ)            : is_well_typed (App t₁ t₂) σ
| wt_abs (s : string) (ty : type) (t : term)
      (σ : list type)
    (h₁ : is_well_typed t (ty :: σ))                     : is_well_typed (Abs s ty t) σ

/-- Infers the type of a term, given an assignment to free variables. Returns none of expression is
    not well-typed. -/
def typeof_p : term → list type → option type
| (Var n)     σ  := σ.nth n
| (Const c)   σ  := some c.type
| (App t₁ t₂) σ  :=
    match typeof_p t₁ σ, typeof_p t₂ σ with
    | (some (type.Arr u v)), (some w) := if u = w then some v else none
    | _                    , _        := none
    end
| (Abs s ty t) σ := match typeof_p t (ty :: σ) with
                    | some ty₂ := some (type.Arr ty ty₂)
                    | _        := none
                    end

-- a boolean version
@[simp]
def is_well_typed_b : term → list type → bool
| (Var n)     σ := if n < σ.length then tt else ff
| (Const c)   σ := tt
| (App t₁ t₂) σ := is_well_typed_b t₁ σ && is_well_typed_b t₂ σ &&
                     (typeof t₁ σ).is_arrow && ((typeof t₁ σ).domain = typeof t₂ σ)
| (Abs s ty t) σ := is_well_typed_b t (ty :: σ)

theorem is_well_typed_iff (t : term) :
  ∀ σ, is_well_typed t σ ↔ (is_well_typed_b t σ = tt) :=
begin
  induction t with _ _ _ _ h₁ h₂ _ ty _ h,
  {intro σ, split, {intro h, cases h; simp [*]}, intro h, simp at h, constructor, assumption},
  {intro σ, split, {intro h, cases h; simp [*]}, intro h, simp at h, constructor},
  {intro σ, simp [(h₁ σ).symm, (h₂ σ).symm], split, {intro h, cases h; simp [*]}, intro h, constructor; simp [*]},
  {intro σ, simp [(h (ty::σ)).symm], split, {intro h, cases h, assumption},
    intro h, constructor; simp [*]}
end

@[simp] lemma is_well_typed_of_is_const {t : term} {σ : list type} :
  is_const t = tt → is_well_typed t σ :=
by { cases t; simp, constructor }

theorem is_well_typed_mk_app (l : list term) (σ : list type) :
  ∀ t, is_well_typed (mk_app t l) σ ↔
         is_well_typed t σ ∧ (∀ t' ∈ l, is_well_typed t' σ) ∧
           l.map (λ t', typeof t' σ) <+: (t.typeof σ).get_arg_types :=
begin
  induction l with t' l' ih,
  { simp [list.nil_prefix] },
  simp, intro t, rw [ih (App t t')], simp [is_well_typed_iff],
  split,
  { intro h, simp [*, typeof] at *,
    rcases h with ⟨⟨h₀, h₁, h₂, h₃⟩, h₄, h₅⟩,
    split, exact h₄, rw [type.eq_of_is_arrow _ h₂],
    simp, rw [h₃], simp, exact h₅},
  intro h, rcases h with ⟨h,  ⟨h₀, h₁⟩, h₂⟩,
  have h₃ := (type.cons_prefix_get_arg_types _ _ _).mp h₂,
  rcases h₃ with ⟨h₃, h₄, h₅⟩,
  simp [h, h₀, h₁, h₃, h₄, h₅, typeof],
  assumption
end

theorem is_well_typed_iff' {t : term} {σ : list type} :
  t.is_well_typed σ ↔
    is_well_typed (t.get_app_fn) σ ∧ (∀ t' ∈ t.get_app_args, is_well_typed t' σ) ∧
           t.get_app_args.map (λ t', typeof t' σ) <+: (t.get_app_fn.typeof σ).get_arg_types :=
by { rw [← mk_app_get_app t, is_well_typed_mk_app], simp [mk_app_get_app] }

theorem typeof_mk_app (t: term) (as : list term) (σ : list type) :
  typeof (mk_app t as) σ =
    type.mk_fn_type (((t.typeof σ).get_arg_types).drop (as.length))
      (t.typeof σ).get_return_type :=
begin
  revert t,
  induction as with a as ih,
  { intro t, simp, rw ← type.mk_fn_type_eq (t.typeof σ) },
  intro t, simp, rw (ih (App t a)), simp [typeof], rw [add_comm, list.drop_add],
  simp [type.get_arg_types_codomain]
end

theorem is_arrow_get_app_fn_of_is_arrow (t : term)(σ : list type) (h : t.is_well_typed σ)
  (h' : (t.typeof σ).is_arrow = tt) : (t.get_app_fn.typeof σ).is_arrow = tt :=
begin
  revert h h',
  induction t with _ _ _ _ ih; simp,
  rintro ⟨h₀, h₁, h₂, h₃⟩, intro h'',
  apply ih; assumption
end

theorem is_arrow_get_app_fn_of_is_app {t : term} {σ : list type} (h : t.is_well_typed σ)
  (h' : is_app t = tt) : ((t.get_app_fn).typeof σ).is_arrow = tt :=
begin
  revert h h',
  cases t; simp,
  intro h, cases h,
  apply is_arrow_get_app_fn_of_is_arrow; assumption
end

theorem typeof_mk_app_is_arrow (t: term) (as : list term) (σ : list type) :
  (typeof (mk_app t as) σ).is_arrow = (as.length < (t.typeof σ).num_arg_types) :=
begin
  rw [typeof_mk_app, type.is_arrow_mk_fn_type, to_bool_eq_to_bool, ne, list.drop_eq_nil,
    lt_iff_not_ge, type.length_get_arg_types], --simp [- bool.to_bool_not],
  apply type.is_arrow_get_return_type_eq_ff
end

theorem length_le_num_arg_types_typeof  {t: term} {as : list term} {σ : list type}
    (h : is_well_typed (mk_app t as) σ) :
  as.length ≤ (t.typeof σ).num_arg_types :=
begin
  have : as.map (λ t', typeof t' σ) <+: (t.typeof σ).get_arg_types,
    from ((is_well_typed_mk_app as σ t).mp h).right.right,
  have := list.length_le_of_prefix this,
  simpa [type.length_get_arg_types]
end

theorem length_get_app_args_of_not_is_arrow {t : term} {σ : list type}
    (h : (t.typeof σ).is_arrow = ff) (h' : t.is_well_typed σ) :
  t.get_app_args.length = (t.get_app_fn.typeof σ).num_arg_types :=
begin
  rw ← mk_app_get_app t at h h',
  have : t.get_app_args.length ≤ (t.get_app_fn.typeof σ).num_arg_types,
    from length_le_num_arg_types_typeof h',
  by {apply le_antisymm this, rw typeof_mk_app_is_arrow at h, simp at h, exact h }
end

theorem get_arg_types_typeof_get_app_fn {t : term} {σ : list type} (h : (t.typeof σ).is_arrow = ff)
     (h' : t.is_well_typed σ) :
  (t.get_app_fn.typeof σ).get_arg_types = t.get_app_args.map (λ t', t'.typeof σ) :=
begin
  have : t.get_app_args.length = (t.get_app_fn.typeof σ).num_arg_types,
    from length_get_app_args_of_not_is_arrow h h',
  rw ← mk_app_get_app t at h h',
  have : t.get_app_args.map (λ t', typeof t' σ) <+: (t.get_app_fn.typeof σ).get_arg_types,
    from ((is_well_typed_mk_app t.get_app_args σ t.get_app_fn).mp h').right.right,
  have : t.get_app_args.map (λ t', typeof t' σ) = (t.get_app_fn.typeof σ).get_arg_types,
    by { apply list.eq_of_prefix_of_length_eq this, rw type.length_get_arg_types, simp, assumption},
  exact this.symm
end

theorem is_well_typed_of_not_is_arrow {t : term} {σ : list type} (h : (t.typeof σ).is_arrow = ff) :
  t.is_well_typed σ ↔
    is_well_typed (t.get_app_fn) σ ∧
    (∀ t' ∈ t.get_app_args, is_well_typed t' σ) ∧
    t.get_app_args.map (λ t', typeof t' σ) = (t.get_app_fn.typeof σ).get_arg_types :=
begin
  split; intro h',
  { have h₀ := is_well_typed_iff'.mp h',
    rcases h₀ with ⟨h₀, h₁, h₂⟩,
    split, apply h₀,
    split, apply h₁,
    apply list.eq_of_prefix_of_length_eq h₂, simp,
    rw length_get_app_args_of_not_is_arrow h h',
    rw [type.length_get_arg_types] },
  rw is_well_typed_iff',
  rcases h' with ⟨h₀, h₁, h₂⟩,
  split, apply h₀,
  split, apply h₁,
  rw h₂
end

theorem typeof_eq_of_not_is_arrow {t : term} {σ : list type}
    (h : (t.typeof σ).is_arrow = ff) (h' : t.is_well_typed σ) :
  t.typeof σ = ((t.get_app_fn).typeof σ).get_return_type :=
begin
  have h₀ : t.typeof σ = (mk_app t.get_app_fn t.get_app_args).typeof σ,
    by rw mk_app_get_app,
  transitivity, exact h₀,
  rw [typeof_mk_app, length_get_app_args_of_not_is_arrow h h', ← type.length_get_arg_types],
  rw (list.drop_eq_nil _ _).mpr, simp, apply le_refl
end

lemma type_is_not_arrow' {t : term} {σ : list type} (h : is_well_typed t σ) :
  (t.typeof σ).is_arrow = ff ↔
     (t.get_app_fn.typeof σ).get_arg_types = (t.get_app_args).map (λ t', t'.typeof σ) :=
begin
  split,
  { intro h₀,
    rw [get_arg_types_typeof_get_app_fn h₀ h] },
  intro h,
  rw ← mk_app_get_app t,
  rw typeof_mk_app,
  have : (get_app_args t).length = (t.get_app_fn.typeof σ).get_arg_types.length,
    by { rw h, simp },
  rw this, rw (list.drop_eq_nil _ _).mpr (le_refl _),
  apply type.is_arrow_get_return_type_eq_ff
end

-- an inductive characterization of well typed terms whose types are not arrows
theorem type_is_not_arrow_iff {σ : list type} :
  ∀ {t : term}, t.is_well_typed σ →
    ((t.typeof σ).is_arrow = ff ↔
      (t.is_var = tt ∧ (t.typeof σ).is_arrow = ff) ∨
      (t.is_const = tt ∧ (t.typeof σ).is_arrow = ff) ∨
      (t.is_app = tt ∧
          (t.get_app_fn.typeof σ).get_arg_types = t.get_app_args.map (λ t', t'.typeof σ))) :=
begin
  intro t,
  induction t with _ _ t₁ t₂ ih₁ ih₂; simp,
  { intro h', simp [type_is_not_arrow' h'] },
  simp [typeof]
end

end term

end hol


/-
Copyright (c) 2017 Gabriel Ebner. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner
-/
import .clause .clause_ops
import .prover_state .misc_preprocessing
open expr list tactic monad decidable

universe u

namespace super

meta def try_option {a : Type u} (tac : tactic a) : tactic (option a) :=
some <$> tac <|> return none

private meta def normalize : expr → tactic expr | e := do
e' ← whnf e reducible,
args' ← e'.get_app_args.mmap normalize,
return $ app_of_list e'.get_app_fn args'

meta def inf_normalize_l (c : clause) : tactic (list clause) :=
on_first_left c $ λtype, do
  type' ← normalize type,
  guard $ type' ≠ type,
  h ← mk_local_def `h type',
  return [([h], h)]

meta def inf_normalize_r (c : clause) : tactic (list clause) :=
on_first_right c $ λha, do
  a' ← normalize ha.local_type,
  guard $ a' ≠ ha.local_type,
  hna ← mk_local_def `hna (imp a' c.local_false),
  return [([hna], app hna ha)]

meta def inf_false_l (c : clause) : tactic (list clause) :=
first $ do i ← list.range c.num_lits,
  if c.get_lit i = clause.literal.left `(false)
  then [return []]
  else []

meta def inf_false_r (c : clause) : tactic (list clause) :=
on_first_right c $ λhf,
  if hf.local_type = c.local_false
  then return [([], hf)]
  else match hf.local_type with
  | const ``false [] := do
    pr ← mk_app ``false.rec [c.local_false, hf],
    return [([], pr)]
  | _ := failed
  end

meta def inf_true_l (c : clause) : tactic (list clause) :=
on_first_left c $ λt,
  match t with
  | (const ``true []) := return [([], const ``true.intro [])]
  | _ := failed
  end

meta def inf_true_r (c : clause) : tactic (list clause) :=
first $ do i ← list.range c.num_lits,
  if c.get_lit i = clause.literal.right (const ``true [])
  then [return []]
  else []

meta def inf_not_l (c : clause) : tactic (list clause) :=
on_first_left c $ λtype,
  match type with
  | app (const ``not []) a := do
    hna ← mk_local_def `h (a.imp `(false)),
    return [([hna], hna)]
  | _ := failed
  end

meta def inf_not_r (c : clause) : tactic (list clause) :=
on_first_right c $ λhna,
  match hna.local_type with
  | app (const ``not []) a := do
    hnna ← mk_local_def `h ((a.imp `(false)).imp c.local_false),
    return [([hnna], app hnna hna)]
  | _ := failed
  end

meta def inf_and_l (c : clause) : tactic (list clause) :=
on_first_left c $ λab,
  match ab with
  | (app (app (const ``and []) a) b) := do
    ha ← mk_local_def `l a,
    hb ← mk_local_def `r b,
    pab ← mk_mapp ``and.intro [some a, some b, some ha, some hb],
    return [([ha, hb], pab)]
  | _ := failed
  end

meta def inf_and_r (c : clause) : tactic (list clause) :=
on_first_right' c $ λhyp, do
  pa ← mk_mapp ``and.left [none, none, some hyp],
  pb ← mk_mapp ``and.right [none, none, some hyp],
  return [([], pa), ([], pb)]

meta def inf_iff_l (c : clause) : tactic (list clause) :=
on_first_left c $ λab,
  match ab with
  | (app (app (const ``iff []) a) b) := do
    hab ← mk_local_def `l (imp a b),
    hba ← mk_local_def `r (imp b a),
    pab ← mk_mapp ``iff.intro [some a, some b, some hab, some hba],
    return [([hab, hba], pab)]
  | _ := failed
  end

meta def inf_iff_r (c : clause) : tactic (list clause) :=
on_first_right' c $ λhyp, do
  pa ← mk_mapp ``iff.mp [none, none, some hyp],
  pb ← mk_mapp ``iff.mpr [none, none, some hyp],
  return [([], pa), ([], pb)]

meta def inf_or_r (c : clause) : tactic (list clause) :=
on_first_right c $ λhab,
  match hab.local_type with
  | (app (app (const ``or []) a) b) := do
    hna ← mk_local_def `l (imp a c.local_false),
    hnb ← mk_local_def `r (imp b c.local_false),
    proof ← mk_app ``or.elim [a, b, c.local_false, hab, hna, hnb],
    return [([hna, hnb], proof)]
  | _ := failed
  end

meta def inf_or_l (c : clause) : tactic (list clause) :=
on_first_left c $ λab,
  match ab with
  | (app (app (const ``or []) a) b) := do
    ha ← mk_local_def `l a,
    hb ← mk_local_def `l b,
    pa ← mk_mapp ``or.inl [some a, some b, some ha],
    pb ← mk_mapp ``or.inr [some a, some b, some hb],
    return [([ha], pa), ([hb], pb)]
  | _ := failed
  end

meta def inf_all_r (c : clause) : tactic (list clause) :=
on_first_right' c $ λhallb,
  match hallb.local_type with
  | (pi n bi a b) := do
    ha ← mk_local_def `x a,
    return [([ha], app hallb ha)]
  | _ := failed
  end

lemma imp_l {F a b} [decidable a] : ((a → b) → F) → ((a → F) → F) :=
λhabf haf, decidable.by_cases
    (assume ha :   a, haf ha)
    (assume hna : ¬a, habf (assume  ha, absurd ha hna))

lemma imp_l' {F a b} [decidable F] : ((a → b) → F) → ((a → F) → F) :=
λhabf haf, decidable.by_cases
    (assume hf :   F, hf)
    (assume hnf : ¬F, habf (assume  ha, absurd (haf ha) hnf))

lemma imp_l_c {F : Prop} {a b} : ((a → b) → F) → ((a → F) → F) :=
λhabf haf, classical.by_cases
    (assume hf :   F, hf)
    (assume hnf : ¬F, habf (assume  ha, absurd (haf ha) hnf))

meta def inf_imp_l (c : clause) : tactic (list clause) :=
on_first_left_dn c $ λhnab,
  match hnab.local_type with
  | (pi _ _ (pi _ _ a b) _) :=
    if b.has_var then failed else do
    hna ← mk_local_def `na (imp a c.local_false),
    pf ← first (do r ← [``super.imp_l, ``super.imp_l', ``super.imp_l_c],
                 [mk_app r [hnab, hna]]),
    hb ← mk_local_def `b b,
    return [([hna], pf), ([hb], app hnab (lam `a binder_info.default a hb))]
  | _ := failed
  end

meta def inf_ex_l (c : clause) : tactic (list clause) :=
on_first_left c $ λexp,
  match exp with
  | (app (app (const ``Exists [u]) dom) pred) := do
    hx ← mk_local_def `x dom,
    predx ← whnf $ app pred hx,
    hpx ← mk_local_def `hpx predx,
    return [([hx,hpx], app_of_list (const ``exists.intro [u])
                       [dom, pred, hx, hpx])]
  | _ := failed
  end

lemma demorgan' {F a} {b : a → Prop} : ((∀x, b x) → F) → (((∃x, b x → F) → F) → F) :=
assume hab hnenb,
  classical.by_cases
    (assume h : ∃x, ¬b x, begin cases h with x, apply hnenb, existsi x, intros, contradiction end)
    (assume h : ¬∃x, ¬b x, hab (assume  x,
      classical.by_cases
        (assume bx : b x, bx)
        (assume nbx : ¬b x, have hf : false, { apply h, existsi x, assumption }, by contradiction)))

meta def inf_all_l (c : clause) : tactic (list clause) :=
on_first_left_dn c $ λhnallb,
  match hnallb.local_type with
  | pi _ _ (pi n bi a b) _ := do
    enb ← mk_mapp ``Exists [none, some $ lam n binder_info.default a (imp b c.local_false)],
    hnenb ← mk_local_def `h (imp enb c.local_false),
    pr ← mk_app ``super.demorgan' [hnallb, hnenb],
    return [([hnenb], pr)]
  | _ := failed
  end

meta def inf_ex_r  (c : clause) : tactic (list clause) := do
(qf, ctx) ← c.open_constn c.num_quants,
skolemized ← on_first_right' qf $ λhexp,
  match hexp.local_type with
  | (app (app (const ``Exists [_]) d) p) := do
    sk_sym_name_pp ← get_unused_name `sk (some 1),
    inh_lc ← mk_local' `w binder_info.implicit d,
    sk_sym ← mk_local_def sk_sym_name_pp (pis (ctx ++ [inh_lc]) d),
    sk_p ← whnf_no_delta $ app p (app_of_list sk_sym (ctx ++ [inh_lc])),
    sk_ax ← mk_mapp ``Exists [some (local_type sk_sym),
      some (lambdas [sk_sym] (pis (ctx ++ [inh_lc]) (imp hexp.local_type sk_p)))],
    sk_ax_name ← get_unused_name `sk_axiom (some 1), assert sk_ax_name sk_ax,
    nonempt_of_inh ← mk_mapp ``nonempty.intro [some d, some inh_lc],
    eps ← mk_mapp ``classical.epsilon [some d, some nonempt_of_inh, some p],
    existsi (lambdas (ctx ++ [inh_lc]) eps),
    eps_spec ← mk_mapp ``classical.epsilon_spec [some d, some p],
    exact (lambdas (ctx ++ [inh_lc]) eps_spec),
    sk_ax_local ← get_local sk_ax_name, cases sk_ax_local [sk_sym_name_pp, sk_ax_name],
    sk_ax' ← get_local sk_ax_name,
    return [([inh_lc], app_of_list sk_ax' (ctx ++ [inh_lc, hexp]))]
  | _ := failed
  end,
return $ skolemized.map (λs, s.close_constn ctx)

meta def first_some {a : Type} : list (tactic (option a)) → tactic (option a)
| [] := return none
| (x::xs) := do xres ← x, match xres with some y := return (some y) | none := first_some xs end

private meta def get_clauses_core' (rules : list (clause → tactic (list clause)))
     : list clause → tactic (list clause) | cs :=
list.join <$> do
cs.mmap $ λc, do first $
rules.map (λr, r c >>= get_clauses_core') ++ [return [c]]

meta def get_clauses_core (rules : list (clause → tactic (list clause))) (initial : list clause)
     : tactic (list clause) := do
clauses ← get_clauses_core' rules initial,
filter (λc, bnot <$> is_taut c) $ list.nub_on clause.type clauses

meta def clausification_rules_intuit : list (clause → tactic (list clause)) :=
[ inf_false_l, inf_false_r, inf_true_l, inf_true_r,
  inf_not_l, inf_not_r,
  inf_and_l, inf_and_r,
  inf_iff_l, inf_iff_r,
  inf_or_l, inf_or_r,
  inf_ex_l,
  inf_normalize_l, inf_normalize_r ]

meta def clausification_rules_classical : list (clause → tactic (list clause)) :=
[ inf_false_l, inf_false_r, inf_true_l, inf_true_r,
  inf_not_l, inf_not_r,
  inf_and_l, inf_and_r,
  inf_iff_l, inf_iff_r,
  inf_or_l, inf_or_r,
  inf_imp_l, inf_all_r,
  inf_ex_l,
  inf_all_l, inf_ex_r,
  inf_normalize_l, inf_normalize_r ]

meta def get_clauses_classical : list clause → tactic (list clause) :=
get_clauses_core clausification_rules_classical
meta def get_clauses_intuit : list clause → tactic (list clause) :=
get_clauses_core clausification_rules_intuit

meta def as_refutation : tactic unit := do
repeat (do intro1, skip),
tgt ← target,
if tgt.is_constant || tgt.is_local_constant then skip else do
local_false_name ← get_unused_name `F none, tgt_type ← infer_type tgt,
definev local_false_name tgt_type tgt, local_false ← get_local local_false_name,
target_name ← get_unused_name `target none,
assertv target_name (imp tgt local_false) (lam `hf binder_info.default tgt $ mk_var 0),
change local_false

meta def clauses_of_context : tactic (list clause) := do
local_false ← target,
l ← local_context,
l.mmap (clause.of_proof local_false)

meta def clausify_pre := preprocessing_rule $ assume  new, list.join <$> new.mmap (λ dc, do
cs ← get_clauses_classical [dc.c],
if cs.length ≤ 1 then
  return (cs.map $ λ c, { dc with c := c })
else
  cs.mmap (λc, mk_derived c dc.sc))

-- @[super.inf]
meta def clausification_inf : inf_decl := inf_decl.mk 0 $
λ given, list.foldr (<|>) (return ()) $
        do r ← clausification_rules_classical,
           [do cs ← r given.c,
               cs' ← get_clauses_classical cs,
               cs'.mmap' (λc, mk_derived c given.sc.sched_now >>= add_inferred),
               remove_redundant given.id []]

end super


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Nathaniel Thomas
-/
import tactic.finish

/-!
# More examples to test `finish`

Shamelessly stolen by Jeremy from Nathaniel's `tauto`.
-/

open nat

section

variables (a b c d e f : Prop)
variable even : ℕ → Prop
variable P : ℕ → Prop

-- these next five are things that tauto doesn't get

example : (∀ x, P x) ∧ b → (∀ y, P y) ∧ P 0 ∨ b ∧ P 0 := by finish
example : (∀ A, A ∨ ¬A) → ∀ x y : ℕ, x = y ∨ x ≠ y := by finish
example : ∀ b1 b2, b1 = b2 ↔ (b1 = tt ↔ b2 = tt) := begin intro b1, cases b1; finish [iff_def] end

example : ∀ (P Q : nat → Prop), (∀ n, Q n → P n) → (∀ n, Q n) → P 2 := by finish
example (a b c : Prop) : ¬ true ∨ false ∨ b ↔ b := by finish

example : true := by finish

example : false → a := by finish
example : a → a := by finish
example : (a → b) → a → b := by finish
example : ¬ a → ¬ a := by finish
example : a → (false ∨ a) := by finish
example : (a → b → c) → (a → b) → a → c := by finish
example : a → ¬ a → (a → b) → (a ∨ b) → (a ∧ b) → a → false := by finish
example : ((a ∧ b) ∧ c) → b := by finish
example : ((a → b) → c) → b → c := by finish
example : (a ∨ b) → (b ∨ a) := by finish
example : (a → b ∧ c) → (a → b) ∨ (a → c) := by finish
example : ∀ (x0 : a ∨ b) (x1 : b ∧ c), a → b := by finish
example : a → b → (c ∨ b) := by finish
example : (a ∧ b → c) → b → a → c := by finish
example : (a ∨ b → c) → a → c := by finish
example : (a ∨ b → c) → b → c := by finish
example : (a ∧ b) → (b ∧ a) := by finish
example : (a ↔ b) → a → b := by finish
example : a → ¬¬a := by finish
example : ¬¬(a ∨ ¬a) := by finish
example : ¬¬(a ∨ b → a ∨ b) := by finish
example : ¬¬((∀ n, even n) ∨ ¬(∀ m, even m)) := by finish
example : (¬¬b → b) → (a → b) → ¬¬a → b := by finish
example : (¬¬b → b) → (¬b → ¬ a) → ¬¬a → b := by finish

example : ((a → b → false) → false) → (b → false) → false := by finish

example : ((((c → false) → a) → ((b → false) → a) → false) → false) →
            (((c → b → false) → false) → false) → ¬a → a := by finish

example (p q r : Prop) (a b : nat) : true → a = a → q → q → p → p := by finish
example : ∀ (F F' : Prop), F ∧ F' → F := by finish
example : ∀ (F1 F2 F3 : Prop), ((¬F1 ∧ F3) ∨ (F2 ∧ ¬F3)) → (F2 → F1) → (F2 → F3) →  ¬F2 := by finish
example : ∀ (f : nat → Prop), f 2 → ∃ x, f x := by finish
example : true ∧ true ∧ true ∧ true ∧ true ∧ true ∧ true := by finish
example : ∀ (P : nat → Prop), P 0 → (P 0 → P 1) → (P 1 → P 2) → (P 2) := by finish
example : ¬¬¬¬¬a → ¬¬¬¬¬¬¬¬a → false := by finish
example : ∀ n, ¬¬(even n ∨ ¬even n) := by finish
example : ∀ (p q r s : Prop) (a b : nat), r ∨ s → p ∨ q → a = b → q ∨ p := by finish
example : (∀ x, P x) → (∀ y, P y) := by finish

/- TODO(Jeremy): reinstate after simp * at * bug is fixed.
example : ((a ↔ b) → (b ↔ c)) → ((b ↔ c) → (c ↔ a)) → ((c ↔ a) → (a ↔ b)) → (a ↔ b) :=
by finish [iff_def]
-/

example : ((¬a ∨ b) ∧ (¬b ∨ b) ∧ (¬a ∨ ¬b) ∧ (¬b ∨ ¬b) → false) → ¬((a → b) → b) → false :=
by finish

example : ¬((a → b) → b) → ((¬b ∨ ¬b) ∧ (¬b ∨ ¬a) ∧ (b ∨ ¬b) ∧ (b ∨ ¬a) → false) → false :=
by finish

example : (¬a ↔ b) → (¬b ↔ a) → (¬¬a ↔ a) := by finish

example : (¬ a ↔ b) → (¬ (c ∨ e) ↔ d ∧ f) → (¬ (c ∨ a ∨ e) ↔ d ∧ b ∧ f) := by finish

example {A : Type} (p q : A → Prop) (a b : A) : q a → p b → ∃ x, (p x ∧ x = b) ∨ q x := by finish

example {A : Type} (p q : A → Prop) (a b : A) : p b → ∃ x, q x ∨ (p x ∧ x = b) := by finish

example : ¬ a → b → a → c := by finish
example : a → b → b → ¬ a → c := by finish
example (a b : nat) : a = b → b = a := by finish

-- good examples of things we don't get, even using the simplifier
example (a b c : nat) : a = b → a = c → b = c := by finish
example (p : nat → Prop) (a b c : nat) : a = b → a = c → p b → p c := by finish

example (p : Prop) (a b : nat) : a = b → p → p := by finish

-- safe should look for contradictions with constructors
example (a : nat) : (0 : ℕ) = succ a → a = a → false := by finish
example (p : Prop) (a b c : nat) : [a, b, c] = [] → p := by finish

example (a b c : nat) : succ (succ a) = succ (succ b) → c = c := by finish
example (p : Prop) (a b : nat) : a = b → b ≠ a → p := by finish
example : (a ↔ b) → ((b ↔ a) ↔ (a ↔ b)) := by finish
example (a b c : nat) : b = c → (a = b ↔ c = a) := by finish [iff_def]
example : ¬¬¬¬¬¬¬¬a → ¬¬¬¬¬a → false := by finish
example (a b c : Prop) : a ∧ b ∧ c ↔ c ∧ b ∧ a := by finish
example (a b c : Prop) : a ∧ false ∧ c ↔ false := by finish
example (a b c : Prop) : a ∨ false ∨ b ↔ b ∨ a := by finish
example : a ∧ not a ↔ false := by finish
example : a ∧ b ∧ true → b ∧ a := by finish
example (A : Type) (a₁ a₂ : A) : a₁ = a₂ →
  (λ (B : Type) (f : A → B), f a₁) = (λ (B : Type) (f : A → B), f a₂) := by finish
example (a : nat) : ¬ a = a → false := by finish
example (A : Type) (p : Prop) (a b c : A) : a = b → b ≠ a → p := by finish
example (p q r s : Prop) : r ∧ s → p ∧ q → q ∧ p := by finish
example (p q : Prop) : p ∧ p ∧ q ∧ q → q ∧ p := by finish
example (p : nat → Prop) (q : nat → nat → Prop) :
  (∃ x y, p x ∧ q x y) → q 0 0 ∧ q 1 1 → (∃ x, p x) := by finish
example (p q r s : Prop) (a b : nat) : r ∨ s → p ∨ q → a = b → q ∨ p := by finish
example (p q r : Prop) (a b : nat) : true → a = a → q → q → p → p := by finish
example (a b : Prop) : a → b → a := by finish
example (p q : nat → Prop) (a b : nat) : p a → q b → ∃ x, p x := by finish

example : ∀ b1 b2, b1 && b2 = ff ↔ (b1 = ff ∨ b2 = ff) := by finish
example : ∀ b1 b2, b1 && b2 = tt ↔ (b1 = tt ∧ b2 = tt) := by finish
example : ∀ b1 b2, b1 || b2 = ff ↔ (b1 = ff ∧ b2 = ff) := by finish
example : ∀ b1 b2, b1 || b2 = tt ↔ (b1 = tt ∨ b2 = tt) := by finish
example : ∀ b, bnot b = tt ↔ b = ff := by finish
example : ∀ b, bnot b = ff ↔ b = tt := by finish
example : ∀ b c, b = c ↔ ¬ (b = bnot c) := by intros b c; cases b; cases c; finish [iff_def]

inductive and3 (a b c : Prop) : Prop
| mk : a → b → c → and3

example (h : and3 a b c) : and3 b c a := by cases h; split; finish

inductive or3 (a b c : Prop) : Prop
| in1 : a → or3
| in2 : b → or3
| in3 : c → or3

/- TODO(Jeremy): write a tactic that tries all constructors
example (h : a) : or3 a b c := sorry
example (h : b) : or3 a b c := sorry
example (h : c) : or3 a b c := sorry
-/

variables (A₁ A₂ A₃ A₄ B₁ B₂ B₃ B₄ : Prop)
-- H first, all pos

example (H1 : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄)
  (a1 : A₁) (a2 : A₂) (a3 : A₃) (n1 : ¬B₁) (n2 : ¬B₂) (n3 : ¬B₃) : B₄ := by finish
example (H1 : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄)
  (a1 : A₁) (a2 : A₂) (a3 : A₃) (n1 : ¬B₁) (n2 : ¬B₂) (n3 : ¬B₄) : B₃ := by finish
example (H1 : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄)
  (a1 : A₁) (a2 : A₂) (a3 : A₃) (n1 : ¬B₁) (n3 : ¬B₃) (n3 : ¬B₄) : B₂ := by finish
example (H1 : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄)
  (a1 : A₁) (a2 : A₂) (a3 : A₃) (n2 : ¬B₂) (n3 : ¬B₃) (n3 : ¬B₄) : B₁ := by finish

example (H : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄)
  (a1 : A₁) (a2 : A₂) (n1 : ¬B₁) (n2 : ¬B₂) (n3 : ¬B₃) (n3 : ¬B₄) : ¬A₃ := by finish
example (H : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄)
  (a1 : A₁) (a3 : A₃) (n1 : ¬B₁) (n2 : ¬B₂) (n3 : ¬B₃) (n3 : ¬B₄) : ¬A₂ := by finish
example (H : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄)
  (a2 : A₂) (a3 : A₃) (n1 : ¬B₁) (n2 : ¬B₂) (n3 : ¬B₃) (n3 : ¬B₄) : ¬A₁ := by finish

-- H last, all pos
example (a1 : A₁) (a2 : A₂) (a3 : A₃) (n1 : ¬B₁) (n2 : ¬B₂) (n3 : ¬B₃)
  (H : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄) : B₄ := by finish
example (a1 : A₁) (a2 : A₂) (a3 : A₃) (n1 : ¬B₁) (n2 : ¬B₂) (n3 : ¬B₄)
  (H : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄) : B₃ := by finish
example (a1 : A₁) (a2 : A₂) (a3 : A₃) (n1 : ¬B₁) (n3 : ¬B₃) (n3 : ¬B₄)
  (H : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄) : B₂ := by finish
example (a1 : A₁) (a2 : A₂) (a3 : A₃) (n2 : ¬B₂) (n3 : ¬B₃) (n3 : ¬B₄)
  (H : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄) : B₁ := by finish

example (a1 : A₁) (a2 : A₂) (n1 : ¬B₁) (n2 : ¬B₂) (n3 : ¬B₃) (n3 : ¬B₄)
  (H : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄) : ¬A₃ := by finish
example (a1 : A₁) (a3 : A₃) (n1 : ¬B₁) (n2 : ¬B₂) (n3 : ¬B₃) (n3 : ¬B₄)
  (H : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄) : ¬A₂ := by finish
example (a2 : A₂) (a3 : A₃) (n1 : ¬B₁) (n2 : ¬B₂) (n3 : ¬B₃) (n3 : ¬B₄)
  (H : A₁ → A₂ → A₃ → B₁ ∨ B₂ ∨ B₃ ∨ B₄) : ¬A₁ := by finish

-- H first, all neg
example (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄)
  (n1 : ¬A₁) (n2 : ¬A₂) (n3 : ¬A₃) (b1 : B₁) (b2 : B₂) (b3 : B₃) : ¬B₄ := by finish
example (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄)
  (n1 : ¬A₁) (n2 : ¬A₂) (n3 : ¬A₃) (b1 : B₁) (b2 : B₂) (b4 : B₄) : ¬B₃ := by finish
example (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄)
  (n1 : ¬A₁) (n2 : ¬A₂) (n3 : ¬A₃) (b1 : B₁) (b3 : B₃) (b4 : B₄) : ¬B₂ := by finish
example (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄)
  (n1 : ¬A₁) (n2 : ¬A₂) (n3 : ¬A₃) (b2 : B₂) (b3 : B₃) (b4 : B₄) : ¬B₁ := by finish

example (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄)
  (n1 : ¬A₁) (n2 : ¬A₂) (b1 : B₁) (b2 : B₂) (b3 : B₃) (b4 : B₄) : ¬¬A₃ := by finish
example (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄)
  (n1 : ¬A₁) (n3 : ¬A₃) (b1 : B₁) (b2 : B₂) (b3 : B₃) (b4 : B₄) : ¬¬A₂ := by finish
example (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄)
  (n2 : ¬A₂) (n3 : ¬A₃) (b1 : B₁) (b2 : B₂) (b3 : B₃) (b4 : B₄) : ¬¬A₁ := by finish

-- H last, all neg
example (n1 : ¬A₁) (n2 : ¬A₂) (n3 : ¬A₃) (b1 : B₁) (b2 : B₂) (b3 : B₃)
  (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄) : ¬B₄ := by finish
example (n1 : ¬A₁) (n2 : ¬A₂) (n3 : ¬A₃) (b1 : B₁) (b2 : B₂) (b4 : B₄)
  (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄) : ¬B₃ := by finish
example (n1 : ¬A₁) (n2 : ¬A₂) (n3 : ¬A₃) (b1 : B₁) (b3 : B₃) (b4 : B₄)
  (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄) : ¬B₂ := by finish
example (n1 : ¬A₁) (n2 : ¬A₂) (n3 : ¬A₃) (b2 : B₂) (b3 : B₃) (b4 : B₄)
  (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄) : ¬B₁ := by finish

example (n1 : ¬A₁) (n2 : ¬A₂) (b1 : B₁) (b2 : B₂) (b3 : B₃) (b4 : B₄)
  (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄) : ¬¬A₃ := by finish
example (n1 : ¬A₁) (n3 : ¬A₃) (b1 : B₁) (b2 : B₂) (b3 : B₃) (b4 : B₄)
  (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄) : ¬¬A₂ := by finish
example (n2 : ¬A₂) (n3 : ¬A₃) (b1 : B₁) (b2 : B₂) (b3 : B₃) (b4 : B₄)
  (H : ¬A₁ → ¬A₂ → ¬A₃ → ¬B₁ ∨ ¬B₂ ∨ ¬B₃ ∨ ¬B₄) : ¬¬A₁ := by finish

section club
variables Scottish RedSocks WearKilt Married GoOutSunday : Prop
theorem NoMember : (¬Scottish → RedSocks) → (WearKilt ∨ ¬RedSocks) → (Married → ¬GoOutSunday) →
                 (GoOutSunday ↔ Scottish) → (WearKilt → Scottish ∧ Married) →
                 (Scottish → WearKilt) → false := by finish
end club

end


import .preamble_results

variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
{E : Type*} [normed_group E] [normed_space 𝕜 E]
{E' : Type*} [normed_group E'] [normed_space 𝕜 E']
{F : Type*} [normed_group F] [normed_space 𝕜 F]
{F' : Type*} [normed_group F'] [normed_space 𝕜 F']
{H : Type*} [topological_space H]
{H' : Type*} [topological_space H']
{G : Type*} [topological_space G]
{G' : Type*} [topological_space G']
(I : model_with_corners 𝕜 E H) (I' : model_with_corners 𝕜 E' H')
(J : model_with_corners 𝕜 F G) (J' : model_with_corners 𝕜 F' G')

section diffeomorph

variables (M : Type*) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]
(M' : Type*) [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M']
(N : Type*) [topological_space N] [charted_space G N] [smooth_manifold_with_corners J N]
(N' : Type*) [topological_space N'] [charted_space G' N'] [smooth_manifold_with_corners J' N']
(n : with_top ℕ)

/-- α and β are homeomorph, also called topological isomoph -/
structure diffeomorph extends M ≃ M' :=
(times_cont_mdiff_to_fun  : smooth I I' to_fun)
(times_cont_mdiff_inv_fun : smooth I' I inv_fun)

infix ` ≃ₘ `:50 := diffeomorph _ _
notation M ` ≃ₘ[` I `;` J `]` N := diffeomorph I J M N

namespace diffeomorph
instance : has_coe_to_fun (diffeomorph I I' M M') := ⟨λ _, M → M', λe, e.to_equiv⟩

lemma coe_eq_to_equiv (h : diffeomorph I I' M M') (x : M) : h x = h.to_equiv x := rfl

/-- Identity map is a diffeomorphism. -/
protected def refl : M ≃ₘ[I; I] M :=
{ smooth_to_fun := smooth_in_charts_id, smooth_inv_fun := smooth_in_charts_id, .. homeomorph.refl M }

/-- Composition of two diffeomorphisms. -/
protected def trans (h₁ : diffeomorph I I' M M') (h₂ : diffeomorph I' J M' N) : M ≃ₘ[I | J] N :=
{ smooth_to_fun  := h₂.smooth_to_fun.comp h₁.smooth_to_fun,
  smooth_inv_fun := h₁.smooth_inv_fun.comp h₂.smooth_inv_fun,
  .. homeomorph.trans h₁.to_homeomorph h₂.to_homeomorph }

/-- Inverse of a diffeomorphism. -/
protected def symm (h : M ≃ₘ[I | J] N) : N ≃ₘ[J | I] M :=
{ smooth_to_fun  := h.smooth_inv_fun,
  smooth_inv_fun := h.smooth_to_fun,
  .. h.to_homeomorph.symm }

end diffeomorph

end diffeomorph


/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import category_theory.sites.sheafification
import category_theory.sites.limits
import category_theory.limits.functor_category
import category_theory.limits.filtered_colimit_commutes_finite_limit

/-!
# Left exactness of sheafification
In this file we show that sheafification commutes with finite limits.
-/

open category_theory
open category_theory.limits
open opposite

universes w v u
variables {C : Type (max v u)} [category.{v} C] {J : grothendieck_topology C}
variables {D : Type w} [category.{max v u} D]
variables [∀ (P : Cᵒᵖ ⥤ D) (X : C) (S : J.cover X), has_multiequalizer (S.index P)]

noncomputable theory

namespace category_theory.grothendieck_topology

/-- An auxiliary definition to be used in the proof of the fact that
`J.diagram_functor D X` preserves limits. -/
@[simps]
def cone_comp_evaluation_of_cone_comp_diagram_functor_comp_evaluation
  {X : C} {K : Type (max v u)} [small_category K]
  {F : K ⥤ Cᵒᵖ ⥤ D} {W : J.cover X} (i : W.arrow)
  (E : cone (F ⋙ J.diagram_functor D X ⋙ (evaluation (J.cover X)ᵒᵖ D).obj (op W))) :
  cone (F ⋙ (evaluation _ _).obj (op i.Y)) :=
{ X := E.X,
  π :=
  { app := λ k, E.π.app k ≫ multiequalizer.ι (W.index (F.obj k)) i,
    naturality' := begin
      intros a b f,
      dsimp,
      rw [category.id_comp, category.assoc, ← E.w f],
      dsimp [diagram_nat_trans],
      simp only [multiequalizer.lift_ι, category.assoc],
    end } }

/-- An auxiliary definition to be used in the proof of the fact that
`J.diagram_functor D X` preserves limits. -/
abbreviation lift_to_diagram_limit_obj
  {X : C} {K : Type (max v u)} [small_category K] [has_limits_of_shape K D]
  {W : (J.cover X)ᵒᵖ} (F : K ⥤ Cᵒᵖ ⥤ D)
  (E : cone (F ⋙ J.diagram_functor D X ⋙ (evaluation (J.cover X)ᵒᵖ D).obj W)) :
  E.X ⟶ (J.diagram (limit F) X).obj W :=
multiequalizer.lift _ _ (λ i,
  (is_limit_of_preserves ((evaluation _ _).obj (op i.Y)) (limit.is_limit _)).lift
  (cone_comp_evaluation_of_cone_comp_diagram_functor_comp_evaluation i E))
begin
  intros i,
  change (_ ≫ _) ≫ _ = (_ ≫ _) ≫ _,
  dsimp [evaluate_combined_cones],
  erw [category.comp_id, category.comp_id, category.assoc,
    category.assoc, ← (limit.lift F _).naturality, ← (limit.lift F _).naturality,
    ← category.assoc, ← category.assoc],
  congr' 1, ext1,
  erw [category.assoc, category.assoc, limit.lift_π, limit.lift_π,
    limit.lift_π_assoc, limit.lift_π_assoc, category.assoc,
    category.assoc, multiequalizer.condition],
  refl,
end

instance (X : C) (K : Type (max v u)) [small_category K] [has_limits_of_shape K D]
  (F : K ⥤ Cᵒᵖ ⥤ D) : preserves_limit F (J.diagram_functor D X) :=
preserves_limit_of_evaluation _ _ $ λ W,
preserves_limit_of_preserves_limit_cone (limit.is_limit _)
{ lift := λ E, lift_to_diagram_limit_obj F E,
  fac' := begin
    intros E k,
    dsimp [diagram_nat_trans],
    ext1,
    simp only [multiequalizer.lift_ι, multiequalizer.lift_ι_assoc, category.assoc],
    change (_ ≫ _) ≫ _ = _,
    dsimp [evaluate_combined_cones],
    erw [category.comp_id, category.assoc, ← nat_trans.comp_app, limit.lift_π, limit.lift_π],
    refl,
  end,
  uniq' := begin
    intros E m hm,
    ext,
    delta lift_to_diagram_limit_obj,
    erw [multiequalizer.lift_ι, category.assoc],
    change _ = (_ ≫ _) ≫ _,
    dsimp [evaluate_combined_cones],
    erw [category.comp_id, category.assoc, ← nat_trans.comp_app, limit.lift_π, limit.lift_π],
    dsimp,
    rw ← hm,
    dsimp [diagram_nat_trans],
    simp,
  end } .

instance (X : C) (K : Type (max v u)) [small_category K] [has_limits_of_shape K D] :
  preserves_limits_of_shape K (J.diagram_functor D X) := ⟨⟩

instance (X : C) [has_limits D] : preserves_limits (J.diagram_functor D X) := ⟨⟩

variables [∀ (X : C), has_colimits_of_shape (J.cover X)ᵒᵖ D]
variables [concrete_category.{max v u} D]
variables [∀ (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ (forget D)]

/-- An auxiliary definition to be used in the proof that `J.plus_functor D` commutes
with finite limits. -/
def lift_to_plus_obj_limit_obj {K : Type (max v u)} [small_category K] [fin_category K]
  [has_limits_of_shape K D] [preserves_limits_of_shape K (forget D)]
  [reflects_limits_of_shape K (forget D)] (F : K ⥤ Cᵒᵖ ⥤ D) (X : C)
  (S : cone (F ⋙ J.plus_functor D ⋙ (evaluation Cᵒᵖ D).obj (op X))) :
  S.X ⟶ (J.plus_obj (limit F)).obj (op X) :=
let
  e := colimit_limit_iso (F ⋙ J.diagram_functor D X),
  t : J.diagram (limit F) X ≅ limit (F ⋙ J.diagram_functor D X) :=
    (is_limit_of_preserves (J.diagram_functor D X) (limit.is_limit _)).cone_point_unique_up_to_iso
    (limit.is_limit _),
  p : (J.plus_obj (limit F)).obj (op X) ≅ colimit (limit (F ⋙ J.diagram_functor D X)) :=
    has_colimit.iso_of_nat_iso t,
  s : colimit (F ⋙ J.diagram_functor D X).flip ≅
    F ⋙ J.plus_functor D ⋙ (evaluation Cᵒᵖ D).obj (op X) :=
      nat_iso.of_components (λ k, colimit_obj_iso_colimit_comp_evaluation _ k) begin
        intros i j f,
        rw [← iso.eq_comp_inv, category.assoc, ← iso.inv_comp_eq],
        ext w,
        dsimp [plus_map],
        erw [colimit.ι_map_assoc, colimit_obj_iso_colimit_comp_evaluation_ι_inv
        ((F ⋙ J.diagram_functor D X).flip) w j,
        colimit_obj_iso_colimit_comp_evaluation_ι_inv_assoc
        ((F ⋙ J.diagram_functor D X).flip) w i],
      rw ← (colimit.ι (F ⋙ J.diagram_functor D X).flip w).naturality,
      refl
    end in
limit.lift _ S ≫ (has_limit.iso_of_nat_iso s.symm).hom ≫ e.inv ≫ p.inv

-- This lemma should not be used directly. Instead, one should use the fact that
-- `J.plus_functor D` preserves finite limits, along with the fact that
-- evaluation preserves limits.
lemma lift_to_plus_obj_limit_obj_fac {K : Type (max v u)} [small_category K] [fin_category K]
  [has_limits_of_shape K D] [preserves_limits_of_shape K (forget D)]
  [reflects_limits_of_shape K (forget D)] (F : K ⥤ Cᵒᵖ ⥤ D) (X : C)
  (S : cone (F ⋙ J.plus_functor D ⋙ (evaluation Cᵒᵖ D).obj (op X))) (k) :
  lift_to_plus_obj_limit_obj F X S ≫ (J.plus_map (limit.π F k)).app (op X) = S.π.app k :=
begin
  dsimp only [lift_to_plus_obj_limit_obj],
  rw [← (limit.is_limit (F ⋙ J.plus_functor D ⋙ (evaluation Cᵒᵖ D).obj (op X))).fac S k,
    category.assoc],
  congr' 1,
  dsimp,
  simp only [category.assoc],
  rw [← iso.eq_inv_comp, iso.inv_comp_eq, iso.inv_comp_eq],
  ext,
  dsimp [plus_map],
  simp only [has_colimit.iso_of_nat_iso_ι_hom_assoc, ι_colim_map],
  dsimp [is_limit.cone_point_unique_up_to_iso, has_limit.iso_of_nat_iso,
    is_limit.map],
  rw limit.lift_π,
  dsimp,
  rw ι_colimit_limit_iso_limit_π_assoc,
  simp_rw [← nat_trans.comp_app, ← category.assoc, ← nat_trans.comp_app],
  rw [limit.lift_π, category.assoc],
  congr' 1,
  rw ← iso.comp_inv_eq,
  erw colimit.ι_desc,
  refl,
end

instance (K : Type (max v u))
  [small_category K] [fin_category K] [has_limits_of_shape K D]
  [preserves_limits_of_shape K (forget D)]
  [reflects_limits_of_shape K (forget D)] :
  preserves_limits_of_shape K (J.plus_functor D) :=
begin
  constructor, intros F, apply preserves_limit_of_evaluation, intros X,
  apply preserves_limit_of_preserves_limit_cone (limit.is_limit F),
  refine ⟨λ S, lift_to_plus_obj_limit_obj F X.unop S, _, _⟩,
  { intros S k,
    apply lift_to_plus_obj_limit_obj_fac },
  { intros S m hm,
    dsimp [lift_to_plus_obj_limit_obj],
    simp_rw [← category.assoc, iso.eq_comp_inv, ← iso.comp_inv_eq],
    ext,
    simp only [limit.lift_π, category.assoc, ← hm],
    congr' 1,
    ext,
    dsimp [plus_map, plus_obj],
    erw [colimit.ι_map, colimit.ι_desc_assoc, limit.lift_π],
    dsimp,
    simp only [category.assoc],
    rw ι_colimit_limit_iso_limit_π_assoc,
    simp only [nat_iso.of_components_inv_app,
      colimit_obj_iso_colimit_comp_evaluation_ι_app_hom, iso.symm_inv],
    dsimp [is_limit.cone_point_unique_up_to_iso],
    rw [← category.assoc, ← nat_trans.comp_app, limit.lift_π],
    refl }
end

instance [has_finite_limits D] [preserves_finite_limits (forget D)]
  [reflects_isomorphisms (forget D)] : preserves_finite_limits (J.plus_functor D) :=
begin
  apply preserves_finite_limits_of_preserves_finite_limits_of_size.{max v u},
  introsI K _ _,
  haveI : reflects_limits_of_shape K (forget D) :=
    reflects_limits_of_shape_of_reflects_isomorphisms,
  apply_instance
end

instance (K : Type (max v u))
  [small_category K] [fin_category K] [has_limits_of_shape K D]
  [preserves_limits_of_shape K (forget D)]
  [reflects_limits_of_shape K (forget D)] :
  preserves_limits_of_shape K (J.sheafification D) :=
limits.comp_preserves_limits_of_shape _ _

instance [has_finite_limits D] [preserves_finite_limits (forget D)]
  [reflects_isomorphisms (forget D)] : preserves_finite_limits (J.sheafification D) :=
limits.comp_preserves_finite_limits _ _

end category_theory.grothendieck_topology

namespace category_theory

variables [∀ (X : C), has_colimits_of_shape (J.cover X)ᵒᵖ D]
variables [concrete_category.{max v u} D]
variables [∀ (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ (forget D)]
variables [preserves_limits (forget D)]
variables [reflects_isomorphisms (forget D)]
variables (K : Type (max v u))
variables [small_category K] [fin_category K] [has_limits_of_shape K D]

instance : preserves_limits_of_shape K (presheaf_to_Sheaf J D) :=
begin
  constructor, intros F, constructor, intros S hS,
  apply is_limit_of_reflects (Sheaf_to_presheaf J D),
  haveI : reflects_limits_of_shape K (forget D) :=
    reflects_limits_of_shape_of_reflects_isomorphisms,
  apply is_limit_of_preserves (J.sheafification D) hS,
end

instance [has_finite_limits D] : preserves_finite_limits (presheaf_to_Sheaf J D) :=
begin
  apply preserves_finite_limits_of_preserves_finite_limits_of_size.{max v u},
  intros, resetI, apply_instance
end

end category_theory


-- import category_theory.universal.zero
-- import category_theory.limits.equalizers
-- import category_theory.over

-- open category_theory

-- universes u v

-- namespace category_theory.limits

-- variables {C : Type u} [𝒞 : category.{u v} C] [has_zero_object.{u v} C]
-- include 𝒞
-- variables {X Y Z : C}

-- structure is_kernel (f : Y ⟶ Z) (ι : X ⟶ Y) :=
-- (w'    : ι ≫ f = zero_morphism _ _)
-- (lift : Π {X' : C} {ι' : X' ⟶ Y} (w : ι' ≫ f = zero_morphism X' Z), X' ⟶ X)
-- (fac'  : Π {X' : C} {ι' : X' ⟶ Y} (w : ι' ≫ f = zero_morphism X' Z), (lift w) ≫ ι = ι' . obviously)
-- (uniq' : Π {X' : C} {ι' : X' ⟶ Y} (w : ι' ≫ f = zero_morphism X' Z) {m : X' ⟶ X} (h : m ≫ ι = ι'), m = lift w . obviously)

-- restate_axiom is_kernel.w'
-- attribute [search] is_kernel.w
-- restate_axiom is_kernel.fac'
-- attribute [simp,search] is_kernel.fac
-- restate_axiom is_kernel.uniq'
-- attribute [search,elim] is_kernel.uniq

-- @[extensionality] lemma is_kernel.ext {f : Y ⟶ Z} {ι : X ⟶ Y} (P Q : is_kernel f ι) : P = Q :=
-- begin cases P, cases Q, obviously end

-- -- TODO should be marked [search]?
-- lemma kernel.w {f : Y ⟶ Z} {X : C} (ι : X ⟶ Y) (k : is_kernel f ι) : ι ≫ f = zero_morphism _ _ := by rw k.w

-- variable (C)

-- class has_kernels :=
-- (kernel : Π {Y Z : C} (f : Y ⟶ Z), C)
-- (ι       : Π {Y Z : C} (f : Y ⟶ Z), kernel f ⟶ Y)
-- (is     : Π {Y Z : C} (f : Y ⟶ Z), is_kernel f (ι f))

-- variable {C}

-- variable [has_kernels.{u v} C]

-- def kernel (f : Y ⟶ Z) : C := has_kernels.kernel.{u v} f
-- def kernel.ι (f : Y ⟶ Z) : kernel f ⟶ Y := has_kernels.ι.{u v} f
-- def kernel.subobject (f : Y ⟶ Z) : over Y := ⟨ kernel f, kernel.ι f ⟩

-- def kernel_of_equalizer {f : Y ⟶ Z} {t : fork f (zero_morphism _ _)} (e : is_equalizer t) : is_kernel f t.ι :=
-- { w' := begin have p := t.w, simp at p, exact p end,
--   lift := λ X' ι' w, e.lift { X := X', ι := ι' },
--   uniq' := λ X' ι' w m h, begin tidy, apply e.uniq { X := X', ι := m ≫ t.ι }, tidy end }

-- -- def equalizer_of_kernel {f : Y ⟶ Z} {t : fork f (zero_morphism _ _)} (k : is_kernel f t.ι) : is_equalizer t :=
-- -- { lift := λ s, begin have e := s.w, tidy, exact k.lift e, end,
-- --   uniq := sorry, }

-- -- def kernels_are_equalizers {f : Y ⟶ Z} (t : fork f (zero_morphism _ _)) : equiv (is_kernel f t.ι) (is_equalizer t) :=
-- -- { to_fun  := equalizer_of_kernel,
-- --   inv_fun := kernel_of_equalizer,
-- --   left_inv  := sorry,
-- --   right_inv := sorry }

-- end category_theory.limits


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

/-!

# Locally surjective morphisms

## Main definitions

- `is_locally_surjective` : A morphism of presheaves valued in a concrete category is locally
  surjective with respect to a grothendieck topology if every section in the target is locally
  in the set-theoretic image, i.e. the image sheaf coincides with the target.

## Main results

- `to_sheafify_is_locally_surjective` : `to_sheafify` is locally surjective.

-/

universes v u w v' u' w'

open opposite category_theory category_theory.grothendieck_topology

namespace category_theory

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

local attribute [instance] concrete_category.has_coe_to_sort concrete_category.has_coe_to_fun

variables {A : Type u'} [category.{v'} A] [concrete_category.{w'} A]

/-- Given `f : F ⟶ G`, a morphism between presieves, and `s : G.obj (op U)`, this is the sieve
of `U` consisting of the `i : V ⟶ U` such that `s` restricted along `i` is in the image of `f`. -/
@[simps (lemmas_only)]
def image_sieve {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G) {U : C} (s : G.obj (op U)) : sieve U :=
{ arrows := λ V i, ∃ t : F.obj (op V), f.app _ t = G.map i.op s,
  downward_closed' := begin
    rintros V W i ⟨t, ht⟩ j,
    refine ⟨F.map j.op t, _⟩,
    rw [op_comp, G.map_comp, comp_apply, ← ht, elementwise_of f.naturality],
  end }

lemma image_sieve_eq_sieve_of_section {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G) {U : C} (s : G.obj (op U)) :
  image_sieve f s = (image_presheaf (whisker_right f (forget A))).sieve_of_section s := rfl

lemma image_sieve_whisker_forget {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G) {U : C} (s : G.obj (op U)) :
  image_sieve (whisker_right f (forget A)) s = image_sieve f s := rfl

lemma image_sieve_app {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G) {U : C} (s : F.obj (op U)) :
  image_sieve f (f.app _ s) = ⊤ :=
begin
  ext V i,
  simp only [sieve.top_apply, iff_true, image_sieve_apply],
  have := elementwise_of (f.naturality i.op),
  exact ⟨F.map i.op s, this s⟩,
end

/-- A morphism of presheaves `f : F ⟶ G` is locally surjective with respect to a grothendieck
topology if every section of `G` is locally in the image of `f`. -/
def is_locally_surjective {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G) : Prop :=
∀ (U : C) (s : G.obj (op U)), image_sieve f s ∈ J U

lemma is_locally_surjective_iff_image_presheaf_sheafify_eq_top {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G) :
  is_locally_surjective J f ↔ (image_presheaf (whisker_right f (forget A))).sheafify J = ⊤ :=
begin
  simp only [subpresheaf.ext_iff, function.funext_iff, set.ext_iff, top_subpresheaf_obj,
    set.top_eq_univ, set.mem_univ, iff_true],
  exact ⟨λ H U, H (unop U), λ H U, H (op U)⟩
end

lemma is_locally_surjective_iff_image_presheaf_sheafify_eq_top'
  {F G : Cᵒᵖ ⥤ (Type w)} (f : F ⟶ G) :
  is_locally_surjective J f ↔ (image_presheaf f).sheafify J = ⊤ :=
begin
  simp only [subpresheaf.ext_iff, function.funext_iff, set.ext_iff, top_subpresheaf_obj,
    set.top_eq_univ, set.mem_univ, iff_true],
  exact ⟨λ H U, H (unop U), λ H U, H (op U)⟩
end

lemma is_locally_surjective_iff_is_iso
  {F G : Sheaf J (Type w)} (f : F ⟶ G) :
  is_locally_surjective J f.1 ↔ is_iso (image_sheaf_ι f) :=
begin
  rw [image_sheaf_ι, is_locally_surjective_iff_image_presheaf_sheafify_eq_top',
    subpresheaf.eq_top_iff_is_iso],
  exact ⟨λ h, @@is_iso_of_reflects_iso _ _ (image_sheaf_ι f) (Sheaf_to_presheaf J _) h _,
    λ h, @@functor.map_is_iso _ _ (Sheaf_to_presheaf J _) _ h⟩,
end

lemma is_locally_surjective_iff_whisker_forget {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G) :
  is_locally_surjective J f ↔ is_locally_surjective J (whisker_right f (forget A)) :=
begin
  simpa only [is_locally_surjective_iff_image_presheaf_sheafify_eq_top]
end

lemma is_locally_surjective_of_surjective {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G)
  (H : ∀ U, function.surjective (f.app U)) : is_locally_surjective J f :=
begin
  intros U s,
  obtain ⟨t, rfl⟩ := H _ s,
  rw image_sieve_app,
  exact J.top_mem _
end

lemma is_locally_surjective_of_iso {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G) [is_iso f] :
  is_locally_surjective J f :=
begin
  apply is_locally_surjective_of_surjective,
  intro U,
  apply function.bijective.surjective,
  rw ← is_iso_iff_bijective,
  apply_instance
end

lemma is_locally_surjective.comp {F₁ F₂ F₃ : Cᵒᵖ ⥤ A} {f₁ : F₁ ⟶ F₂} {f₂ : F₂ ⟶ F₃}
  (h₁ : is_locally_surjective J f₁) (h₂ : is_locally_surjective J f₂) :
    is_locally_surjective J (f₁ ≫ f₂) :=
begin
  intros U s,
  have : sieve.bind (image_sieve f₂ s) (λ _ _ h, image_sieve f₁ h.some) ≤ image_sieve (f₁ ≫ f₂) s,
  { rintros V i ⟨W, i, j, H, ⟨t', ht'⟩, rfl⟩,
    refine ⟨t', _⟩,
    rw [op_comp, F₃.map_comp, nat_trans.comp_app, comp_apply, comp_apply, ht',
      elementwise_of f₂.naturality, H.some_spec] },
  apply J.superset_covering this,
  apply J.bind_covering,
  { apply h₂ },
  { intros, apply h₁ }
end

section

variables (F : Cᵒᵖ ⥤ Type (max u v))

/-- The image of `F` in `J.sheafify F` is isomorphic to the sheafification. -/
noncomputable
def sheafification_iso_image_presheaf :
  J.sheafify F ≅ ((image_presheaf (J.to_sheafify F)).sheafify J).to_presheaf :=
{ hom := J.sheafify_lift (to_image_presheaf_sheafify J _)
  ((is_sheaf_iff_is_sheaf_of_type J _).mpr $ subpresheaf.sheafify_is_sheaf _ $
    (is_sheaf_iff_is_sheaf_of_type J _).mp $ sheafify_is_sheaf J _),
  inv := subpresheaf.ι _,
  hom_inv_id' := J.sheafify_hom_ext _ _ (J.sheafify_is_sheaf _)
    (by simp [to_image_presheaf_sheafify]),
  inv_hom_id' := begin
    rw [← cancel_mono (subpresheaf.ι _), category.id_comp, category.assoc],
    refine eq.trans _ (category.comp_id _),
    congr' 1,
    exact J.sheafify_hom_ext _ _ (J.sheafify_is_sheaf _) (by simp [to_image_presheaf_sheafify]),
    apply_instance
  end }

-- We need to sheafify
variables {B : Type w} [category.{max u v} B]
  [concrete_category.{max u v} B]
  [∀ (X : C), limits.has_colimits_of_shape (J.cover X)ᵒᵖ B]
  [∀ (P : Cᵒᵖ ⥤ B) (X : C) (S : J.cover X), limits.has_multiequalizer (S.index P)]
  [Π (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ B),
    limits.preserves_limit (W.index P).multicospan (forget B)]
  [Π (X : C), limits.preserves_colimits_of_shape (J.cover X)ᵒᵖ (forget B)]
  [∀ (α β : Type (max u v)) (fst snd : β → α),
    limits.has_limits_of_shape (limits.walking_multicospan fst snd) B]

lemma to_sheafify_is_locally_surjective (F : Cᵒᵖ ⥤ B) :
  is_locally_surjective J (J.to_sheafify F) :=
begin
  rw [is_locally_surjective_iff_whisker_forget, ← to_sheafify_comp_sheafify_comp_iso_inv],
  apply is_locally_surjective.comp,
  { rw [is_locally_surjective_iff_image_presheaf_sheafify_eq_top, subpresheaf.eq_top_iff_is_iso],
    exact is_iso.of_iso_inv (sheafification_iso_image_presheaf J (F ⋙ forget B)) },
  { exact is_locally_surjective_of_iso _ _ }
end

end

end category_theory